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1. Ubersicht uber die insertierten Pakete 



'(M)' vor der Paketnummer heiBt, daB dies Objekt nur im Mutti - User vorhanden ist. 
'(S)' vor der Paketnummer heiSt, daB dies Objekt nur im Single - User vorhanden ist. 
'(T)' vor der Paketnummer heiBt, daB dies Objekt nur in einem System mit Textverar- 
beitung vorhanden ist. 

Die Paketnummer ergibt sich aus der Reihenfolge, in der die Pakete Im Multi-User mit 
Textverarbeitung insertiert wurden. Bitte beachten Sie, daB diese Reihenfolge nicht der 
Insertierungsreihenfolge im Single - User entspricht. Der Quellcode der insertierten Pakete 
ist in Teil 4 nach Paketnummern sortiert. 
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2. Obersicht uber die exportierten Objekte nach Paketen geordnet: 



'(M)* vor der Paketnummer heiBt, daB dies Objekt nur im Multi- User vorhanden ist. 
'(S)' vor der Paketnummer heiSt, daB dies Objekt nur im Single - User vorhanden ist. 
'(T)' vor der Paketnummer heiBt, daB dies Objekt nur in einem System mit Textverar- 
beitung vorhanden ist. 

Die Paketnummer ergibt sich aus der Reihenfolge, in der die Pakete im Multi - User mit 
Textverarbeitung insertiert wurden. Bitte beachten Sie, daB diese Reihenfolge nicht der 
Insertierungsreihenfolge im Single -User entspricht. Der Quellcode der insertierten Pakete 
ist in Teil 4 nach Paketnummern sortiert. 



PACKET a : 



PACKET bits : 



PROC rotate (INT VAR bits, INT CONST number of bits; 2-19 

INT OP AND (INT CONST left, right) 2-23 

INT OP OR (INT CONST left, right) 2-27 

INT OP XOR (INT CONST left, right) 2-31 

BOOL PROC bit (INT CONST bits, bit no) 2-35 

PROC set bit (INT VAR bits, INT CONST bit no) 2-41 

PROC reset bit (INT VAR bits, INT CONST bit no) 2-47 

INT PROC lowest set (INT CONST bits) 2-53 

INT PROC lowest reset (INT CONST bits) 2-65 

PACKET text : 

INT CONST max text length 3-35 

TEXT OP SUB (TEXT CONST text, INT CONST pos) 3-37 

TEXT PROC subtext (TEXT CONST source, INT CONST from, to) 3-41 

TEXT PROC subtext (TEXT CONST source, INT CONST from) 3-45 

INT PROC code (TEXT CONST text) 3-49 

TEXT PROC code (INT CONST code) 3-53 

INT OP ISUB (TEXT CONST text, INT CONST index) 3-57 

PROC replace (TEXT VAR text, INT CONST index, value) 3-61 

REAL OP RSUB (TEXT CONST text, INT CONST index) 3-65 

PROC replace (TEXT VAR text, INT CONST Index, REAL CONST code) 3-69 

PROC replace (TEXT VAR dest, INT CONST pos, TEXT CONST source) 3-74 

TEXT PROC text (TEXT CONST source, INT CONST length) 3-78 

TEXT PROC text (TEXT CONST source, im CONST length, from) 3-95 

OP CAT (TEXT VAR right, TEXT CONST left) 3-99 

TEXT OP + (TEXT CONST left, right) 3-103 

TEXT OP • (INT CONST times, TEXT CONST source) 3-109 

INT PROC length (TEXT CONST text) 3-12© 

INT OP LENGTH (TEXT CONST text) 3-124 

INT PROC pos (TEXT CONST source, pattern) 3-128 

INT PROC pos (TEXT CONST source, pattern, INT CONST from) 3-132 

INT PROC pos (TEXT CONST source, pattern, INT CONST from, to) 3-136 

INT PROC pos (TEXT CONST source, low, high, INT CONST from) 3-140 
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TEXT ?BOC compress (TEXT CONST text) 3-144 

PROC change ^TEXT VAR destination, INT CONST from, to, TEXT CONST new) 3-167 

PROC change (TEXT VAR destination, TEXT CONST old, new) 3-183 

PROC delete char (TEXT VAR string, INT CONST delete pos) 3-214 

PROC insert char (TEXT VAR string, TEXT CONST char, INT CONST insert pos) 3-224 

INT PROC heap size 3-236 

PROC collect heap garbage 3-24© 
PROC stranalyze (ROW 256 INT CONST table, INT VAR sum, INT CONST max sum, 
TEXT CONST string, INT VAR index, INT CONST to, 

INT VAR exit code) 3-244 

BOOL OP LEXE(5UAL (TEXT CONST left, right) 3-262 

BOOL OP LEXGREATER (TEXT CONST left, right) 3-269 

BOOL OP LEXGREATEREQUAL (TEXT CONST left, right) 3-276 

OP CAT (TEXT VAR result, INT CONST number) 3-374 

PROC insert int (TEXT VAR result, INT CONST insert pos, number) 3-379 

PROC delete int (TEXT VAR result, INT CONST delete pos) 3-385 

PACKET pcb and init control : 

TYPE INITPLAG 4-19 

INT PROC session- 4-22 

INT PROC pcb (INT CONST field) 4-26 

PROC set line nr (INT CONST value) 4-34 

OP := (INITPLAG VAR flag, BOOL CONST flagtrue) 4-39 

BOOL PROC initialized (INITPLAG VAR flag) 4-5© 

REAL PROC clock (INT CONST nr) 4-62 

PROC storage (INT VAR size, used) 4-66 

INT PROC id (INT CONST no) 4-7© 

PROC ke 4-74 

PACKET dataspace : 

TYPE ALIGN 5-21 

OP :- (DATASPACE VAR dest, DATASPACE CONST source) 5-23 

DATASPACE PROC nilspace 5-27 

PROC forget (DATASPACE CONST dataspace) 5-31 

PROC type (DATASPACE CONST ds, INT CONST type) 5-35 

INT PROC type (DATASPACE CONST ds) 5-39 

INT PROC heap size (DATASPACE CONST ds) 5-43 

INT PROC storage (DATASPACE CONST dsj 5-47 

INT PROC ds pages (DATASPACE CONST ds) 5-51 

INT PROC next ds page (DATASPACE CONST ds, INT CONST page nr) 5-59 
PROC blockout (DATASPACE CONST ds. INT CONST page nr, codel, code2, 

INT VAR return code) 5-63 

PROC blockin (DATASPACE VAR ds, INT CONST page nr, codel, code2, 

INT VAR return code) 5-68 

PACKET basic transput : 

PROC out (TEXT CONST text) 6-35 

PROC outsubtext (TEXT CONST source, INT CONST from) 6-39 

PROC outsubtext (TEXT CONST source, INT CONST from, to) 6-43 

PROC outtext (TEXT CONST source, INT CONST from, to) 6-47 

OP TIMESOUT (INT CONST times, TEXT CONST text) 6-59 

PROC display (TEXT CONST text) 6-81 

PROC inchar (TEXT VAR character) 6-87 

TEXT PROC Incharety 6-91 
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TEXT PROC incharety (INT CONST time limit) 6-95 

PROC pause (INT CONST time limit) 6-10© 

PROC pause 6-105 

PROC cat input (TEXT VAR t, esc char) 6-113 

PROC cursor (INT CONST x, y) 6-118 

PROC get cursor (INT VAR x, y) 6-124 

PROC cout (INT CONST number) 6-128 

INT PROC channel 6-133 

BOOL PROC online 6-137 

PROC control (INT CONST codel, code2, code3, INT VaR return code) 6-142 
PROC blockout (ROW 256 INT CONST block, INT CONST codel, code2, 

INT VAR return code) 6-146 
PROC blockin (ROW 256 INT VAR block, INT CONST codel, code2, 

INT VAR return code) 6-161 

PACKET bool : 

BOOL CONST true 7-4 

BOOL CONST false 7-4 

BOOL OP XOR (BOOL CONST left, right) 7-7 

PACKET integer : 

INT PROC minint 8-7 

INT PROC maxint 8-9 

TEXT PROC text (INT CONST number) 8-12 

TEXT PROC text (INT CONST number, length) 8-25 

INT PROC int (TEXT CONST number) 8-38 

INT OP MOB (INT CONST left, right) 8-95 

INT PROC sign (INT CONST argument) 8-101 

INT OP SIGN (INT CONST argument) 8-110 

INT PROC abs (INT CONST argument) 8-114 

INT OP ABS (INT CONST argument) 8-122 

INT OP — (INT CONST arg, exp) 8-126 

INT PROC min (INT CONST first, second) 8-154 

INT PROC max (INT CONST first, second) 8-160 

BOOL PROC last conversion ok 8-170 

PROC set conversion (BOOL CONST success) 8-174 

PROC initialize random (INT CONST start) 8-197 

INT PROC random (INT CONST lower bound, upper bound) 8-208 

PACKET error handling : 

PROC enable stop 9-28 

PROC disable stop 9-32 

BOOL PROC is error 9-40 

PROC clear error 9-44 

TEXT PROC error message 9-72 

INT PROC error code 9-79 

INT PROC error line 9-85 

PROC errcrstop (TEXT CONST message) 9-101 

PROC errorstop (INT CONST code, TEXT CONST message) 9-107 

PROC put error 9-116 

PROC stop 9-135 
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PACKET real 



REAL PROC max real 


10-40 
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INT PROC decimal exponent (REAL CONST mantissa) 
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PROC set exp (INT CONST exponent, REAL VAR number) 
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REAL OP MOD (REAL CONST left, right) 
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OP INCR (REAL VAR dest, REAL CONST increment) 
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PACKET date handling : 



REAL PROC day 11-28 

REAL PROC hour 11-29 

REAL PROC minute 11-3© 

REAL PROC second 11-31 

TEXT PROC date 11-33 

TEXT PROC date (REAL CONST datum) 11-44 

TEXT PROC day (REAL CONST datum) 11-128 

TEXT PROC month (REAL CONST datum) 11-139 

TEXT PROC year (REAL CONST datum) 11-156 

TEXT PROC time of day 11-166 

TEXT PROC time of day (REAL CONST value) 11-17© 

TEXT PROC time (REAL CONST value) 11-174 

TEXT PROC time (REAL CONST value, INT CONST length) 11-178 

REAL PROC date (TEXT CONST datum) 11-201 

REAL PROC time (TEXT CONST time) 11-260 

REAL CONST hour 11-265 



PACKET cx)mmand dialogue : 



TYPE QUIET 12-29 

QUIET PROC quiet 12-31 

BOOL PROC command dialogue 12-36 

PROC coonand dialogue (BOOL CONST status) 12-40 

BOOL PROC yes (TEXT CONST question) 12-45 

BOOL PROC no (TEXT CONST question) 12-81 

PROC say (TEXT CONST message) 12-87 

PROC param position (INT CONST x) 12-95 

TEXT PROC last param 12-101 

PROC last param (TEXT CONST new) 12-114 

TEXT PROC std 12-118 
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PACKET thesaurus handling 



TYPE THESAURUS 

THESAURUS PROC empty thesaurus 

OP :- (THESAURUS VAR dest, THESAURUS CONST source) 

PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) 

PROC insert (THESAURUS VAR thesaurus, TEXT CONST name) 

PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) 

PROC delete (THESAURUS VAR thesaurus, INT CONST index) 

BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name) 

PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) 

PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) 

INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) 

TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) 

PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) 

INT PROC highest entry (THESAURUS CONST thesaurus) 



PACKET local manager : 

PROC create (TEXT CONST name) 
DATASPACE PROC new (TEXT CONST name) 
lATASPACE PROC old (TEXT CONST name) 

DATASPACE PROC old (TEXT CONST name, INT CONST expected type) 

BOOL PROC exists (TEXT CONST name) 

PROC forget (TEXT CONST name) 

PROC forget (TEXT CONST name, QUIET CONST q) 

PROC forget 

PROC status (TEXT CONST name, status text) 
TEXT PROC status (TEXT CONST name) 

PROC status (INT CONST pos, TEXT CONST status pattern) 
PROC copy (DATASPACE CONST source, TEXT CONST dest name) 
PROC copy (TEXT CONST source name, dest name) 
PROC rename (TEXT CONST old name, new name) 
PROC begin list 

PROC get list entry (TEXT VAR entry, status text) 

TEXT PROC write password 

TEXT PROC read password 

PROC enter password (TEXT CONST password) 

PROC enter password (TEXT CONST file name, write pass, read pass) 
BOOL PROC read permission (TEXT CONST name, supply password) 
BOOL PROC write permission (TEXT CONST name, supply password) 
THESAURUS PROC all 



PACKET pattern match : 

TEXT OP - (TEXT CONST alphabet) 

TEXT OP OR (TEXT CONST a, b) 

TEXT OP (TEXT CONST p. INT CONST x) 

TEXT CONST any 

TEXT PROC any (INT CONST n) 

TEXT PROC any (TEXT CONST a) 

TEXT PROC any (INT CONST n, TEXT CONST a) 

TEXT PROC notion (TEXT CONST t) 

TEXT CONST bound 

TEXT PROC match (INT CONST x) 

INT PROC matchpos (INT CONST x) 

INT PROC matchend (INT CONST x) 
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TEXT PROC somefix (TEXT CONST pattern) 

BOOL OP UNLIKE (TEXT CONST t, p) 

BOOL OP LIKE (TEXT CONST t, pattern) 

TEXT PROC notion (TEXT CONST t, INT CONST r) 



PACKET file handling : 

TYPE PILE 
TYPE PRANGE 

OP (PILE VAR left, PILE CONST right) 
TEXT PROC prefix (TEXT CONST pattern) 
BOOL PROC pattern found 
TRANSPUTIIRECTION PROC Input 
TRANSPUTIIRECTION PROC output 
TRANSPUTIIRECTION PROC modify 

PILE PROC sequential file (TRANSPUTIIRECTION CONST mode, 

lATASPACE CONST ds) 
PILE PROC sequential file (TRANSPUTIIRECTION CONST mode, TEXT CONST name) 
PROC reset (PILE VAR f ) 

PROC reset (PILE VAR f, TRANSPUTIIRECTION CONST mode) 
PROC input (PILE VAR f ) 
PROC output (PILE VAR f ) 
PROC modify (PILE VAR f) 
PROC close (PILE VAR f) 

PROC to line (PILE VAR f, INT CONST destination line) 

PROC to first record (PILE VAR f) 

PROC to eof (PILE VAR f ) 

PROC putline (PILE VAR f , TEXT CONST word) 

PROC delete record (PILE VAR f ) 

PROC insert record (PILE VAR f) 

PROC down (PILE VAR f) 

PROC up (PILE VAR f) 

PROC down (PILE VAR f, INT CONST n) 

PROC up (PILE VAR f , INT CONST n) 

PROC write record (PILE VAR f, TEXT CONST record) 

PROC read record (PILE CONST f» TEXT VAR record) 

PROC line (PILE VAR f) 

PROC line (PILE VAR f, INT CONST lines) 

PROC getllne (PILE VAR f, TEXT VAR text) 

BOOL PROC is first record (PILE CONST f) 

BOOL PROC eof (PILE CONST f ) 

INT PROC line no (PILE CONST f) 

PROC line type (PILE VAR f . INT CONST t) 

INT PROC line type (PILE OONST f) 

PROC put (PILE VAR f, TEXT CONST word) 

PROC put (PILE VAR f , INT OONST value) 

PROC put (PILE VAR f, REAL CONST real) 

PROC write (FILE VAR f, TEXT CONST word) 

PROC get (PILE VAR f, TEXT VAR word, TEXT CONST separator) 

PROC get (FILE VAR f, TEXT VAR word, INT CONST max length) 

PROC get (FILE VAR f, TEXT VAR word) 

PROC get (FILE VAR f , INT VAR number) 

PROC get (FILE VAR f, REAL VAR number) 

PROC split line (FILE VAR f, INT CONST split col) 

PROC split line (FILE VAR f , INT CONST split col, 

BOOL CONST note Indentation) 
PROC concatenate line (FILE VAR f, BOOL CONST delete blanks) 
PROC set range (FILE VAR f, INT CONST start line, start col» 
PRANGE VAR old range) 
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PROC set range (PILE VAR f, FRANCE VAR new range) 16-1620 

PROC reset range (PILE VAR fj 16-1668 

PROC remove (PILE VAR f, INT CONST size) 16-1679 

PROC clear removed (PILE VAR f) 16-1687 

PROC reinsert (PILE VAR f) 16-1695 

PROC copy attributes (PILE CONST source file, PILE VAR dest file) 16-1703 

INT PROC max line length (PILE CONST f ) 16-1716 

PROC max line length (PILE VAR f, INT CONST new limit) 16-1723 

TEXT PROC headline (PILE CONST f) 16-1732 

PROC headline (PILE VAR f, TEXT CONST head) 16-1739 

PROC get tabs (PILE CONST f, TEXT VAR tabs) 16-1746 

PROC put tabs (PILE VAR f, TEXT CONST tabs) 16-1753 

INT PROC edit info (PILE CONST f) 16-1760 

PROC edit info (PILE VAR f, INT CONST info) 16-1767 

INT PROC lines (PILE CONST f) 16-1774 

INT PROC removed lines (PILE CONST f ) 16-1761 

INT PROC segments (PILE CONST f) 16-1788 

INT PROC col (PILE CONST f ) 16-1795 

PROC col (PILE VAR f, INT CONST new column) 16-1801 

TEXT PROC word (PILE CONST f) 16-1809 

TEXT PROC word (PILE CONST f , TEXT CONST delimiter) 16-1815 

TEXT PROC word (PILE CONST f, INT CONST max length) 16-1825 

BOOL PROC at (PILE CONST f, TEXT CONST word) 16-1831 

PROC exec (PROC (TEXT VAR, TEXT CONST) proc, PILE VAR f , TEXT CONST t) 16-1844 

PROC exec (PROC (TEXT VAR, INT CONST) proc, PILE VAR f, INT CONST i) 16-1853 

INT PROC pos (PILE CONST f, TEXT CONST pattern, INT CONST i) 16-1861 

PROC down (PILE VAR f, TEXT CONST pattern) 16-1869 

PROC down (PILE VAR f, TEXT CONST pattern, INT CONST max line) 16-1875 

PROC downety (PILE VAR f , TEXT CONST pattern) 16-1884 

PROC downety (PILE VAR f, TEXT CONST pattern, INT CONST max line) 16-1890 

PROC up (PILE VAR f , TEXT CONST pattern) 16-1899 

PROC up (PILE VAR f, TEXT CONST pattern, INT CONST max line) 16-1905 

PROC uppety (PILE VAR f, TEXT CONST pattern) 16-1914 

PROC uppety (PILE VAR f, TEXT CONST pattern, INT CONST max line) 16-1920 

INT PROC len (PILE CONST f ) 16-1930 

TEXT PROC subtext (PILE CONST f, INT CONST from, to) 16-1938 

PROC change (PILE VAR f, INT CONST from, to, TEXT CONST new) 16-1946 

BOOL PROC mark (PILE CONST f ) 16-1956 

PROC mark (PILE VAR f, INT CONST line no, col) 16-1962 

INT PROC mark line no (PILE CONST f) 16-1973 

INT PROC mark col (FILE CONST f) 16-1982 

PROC set marked range (PILE VAR f, PRANGE VAR old range) 16-1993 

PROC sort (TEXT CONST dateiname) 16-2016 

PROC sort (TEXT CONST dateiname, INT CONST sortleranf ang ) 16-202© 

PROC lex sort (TEXT CONST dateiname) 16-2025 

PROC lex sort (TEXT CONST dateiname, INT CONST sortleranf ang) 16-2029 



PACKET elan do interface : 

PROC do (TEXT CONST command) 17-23 
PROC no do again 17-44 



PACKET scanner : 

PROC scan (TEXT CONST scan text) 18-36 

PROC continue scan (TEXT CONST scan text) 18-44 

PROC next symbol (TEXT VAR symbol) 18-52 

PROC next symbol (TEXT VAR symbol, INT VAR type) 18-59 
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PROC scan (riLE VAR f ) 18-296 

PROC next symbol (PILE VAR f, TEXT VAR symbol) 18-303 

PROC next symbol (PILE VAR f, TEXT VAR symbol, INT VAR type) 18-312 

PACKET screen description : 

INT PROC xsize 19-9 

INT PROC ysize 19-11 

INT PROC markslzo 19-13 

PROC xsize (INT CONST i) 19-15 

PROC ysize (INT CONST i) 19-17 

PROC raarksize (INT CONST i) 19-19 

BOOL PROC mark refresh line mode 19-24 

PROC mark refresh line mode (BOOL CONST b) 19-28 

PACKET tasten verwaltung : 

PROC lernsequenz auf taste legen (TEXT CONST taste, lernsequenz) 20-27 

TEXT PROC lernsequenz auf taste (TEXT CONST taste) 20-63 

PROC kommando auf taste legen (TEXT CONST taste, kommando) 20-71 

TEXT PROC kommando auf taste (TEXT CONST taste) 20-79 

BOOL PROC taste enthaelt kommando (TEXT CONST taste) 20-87 

PROC std tastenbelegung 20-92 

PACKET editor paket : 

PROC editget command (BOOL CONST schalter) 21-81 

PR<X editget (TEXT VAR edltsatz, INT CONST editlimit, editlaenge, 

TEXT CONST sep, res, TEXT VAR exit char) 21-87 

PROC editget (TEXT VAR editsatz, INT CONST editlimit, TEXT VAR exit char) 21-192 

PROC editget (TEXT VAR edltsatz, TEXT CONST sep, res, TEXT VAR exit char) 21-196 

PROC editget (TEXT VAR editsatz) 21-200 

PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge) 21-205 

BOOL PROC is editget 21-913 

PROC get oditline (TEXT VAR editline, INT VAR editpos, editraarke) 21-917 

PROC put editline (TEXT CONST editline, INT CONST editpos, editmarke) 21-925 

BOOL PROC within kanji (TEXT CONST satz, INT CONST stelle) 21-933 

BOOL PROC is kanji esc (TEXT CONST char) 21-947 

BOOL PROC two bytes 21-952 

PROC two bytes (BOOL CONST new mode) 21-954 

BOOL PROC write permission 21-989 

PROC push (TEXT CONST ausfuohrkommando ) 21-991 

PRCX: type (TEXT CONST ausfuehrkomraando ) 21-1009 

PROC getchar (TEXT VAR zeichen) 21-1173 

BOOL PROC is incharety (TEXT CONST muster) 21-1194 

TEXT PROC getcharety 21-1208 

PROC get editcursor (INT VAR x, y) 21-1219 

INT PROC aktueller editor 21-1279 

INT PROC groesster editor 21-1281 

PROC quit last 21-2144 

PROC quit 21-2153 

INT CONST aktueller editor 21-2158 

PROC nichts neu 21-2217 

PROC satznr neu 21-2219 

PROC ueberschrift neu 21-2221 

PROC zelle neu 21-2223 

PR<X; abschnitt neu (INT CONST von satznr, bis satznr) 21-2228 
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PROC bildabschnitt neu (INT CONST von zeile, bis zeile) 

VBOC bild neu 

PROC bild neu (FILE VAR f J 

PROC alles neu 

PROC satznr zelgen 

PROC ueberschrift zeigen 

PROC bild zeigen 

PROC set busy indicator 

PROC word wrap (BOOL CONST b)' 

BOOL PROC word wrap 

INT PROC margin 

PROC margin (INT CONST i) 

BOOL PROC rubin mode 

BOOL PROC rubin mode (INT CONST editor nr) 
PROC edit (INT CONST i, TEXT CONST res, PROC 
(TEXT CONST) Icommando interpreter) 
PROC edit (INT CONST von» bis, start, TEXT CONST res. PROC 

(TEXT CONST) kommando Interpreter) 
PROC open editor (PILE CONST new file, BOOL CONST access) 
PROC open editor (INT CONST editor nr, FILE CONST new file, 

BOOL CONST access, INT CONST x start, y, x len start, 
y len) 

PROC open editor (lOT CONST i) 
FILE PROC edltflle 

PROC get window (INT VAR x, y, x size, y size) 



PACKET editor functions : 

PROC std kommando interpreter (TEXT CONST taste) 
PROC edit (FILE VAR f) 

PROC edit (FILE VAR f, INT CONST x, y, x size, y size) 

PROC edit (FILE VAR f, TEXT CONST res. PROC (TEXT CONST) kdo interpreter) 

PROC edit 

PROC edit (TEXT CONST filename) 

PROC edit (TEXT CONST filename, INT CONST x, y, x size, y size) 

PROC edit (INT CONST i) 

PROC show (FILE VAR f) 

PROC show (TEXT CONST filename) 

PROC show 

OP PUT (TEXT CONST filename) 
OP P (TEXT CONST filename) 
OP GET (TEXT CONST filename) 
OP G (TEXT CONST filename) 
INT PROC len 

PROC col (INT CONST stelle) 
INT PROC col 

PROC limit (INT CONST limit) 
INT PROC limit 
INT PROC lines 
INT PROC line no 

PROC to line (INT CONST satz nr) 

OP T (INT OONST satz nr) 

PROC down (INT CONST anz) 

OP D (INT CONST anz) 

PROC up (INT CONST anz) 

OP U (INT CONST anz) 

PROC down (TEXT OONST muster) 

OP D (TEXT CONST muster) 

PROC down (TEXT CONST muster, INT CONST anz) 



21-2237 
21-2249 
21-2251 
21-2261 
21-2270 
21-2274 
21-2417 
21-2508 
21-2607 
21-2623 
21-2630 
21-2632 
21-2653 
21-2655 

21-2665 

21-267© 
21-2753 



21-2792 
21-2881 
21-2929 
21-2935 



22-58 

22-176 

22-186 

22-193 

22-200 

22-233 

22-250 

22-261 

22-266 

22-273 

22-283 

22-293 

22-362 

22-367 

22-438 

22-443 

22-448 

22-453 

22-458 

22-463 

22-468 

22-473 

22-478 

22-486 

22-493 

22-496 

22-503 

22-508 

22-513 

22-525 

22-530 
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PROC up (TEXT CONST muster) 

OP U (TEXT CONST muster) 

PROC up (TEXT CONST muster, INT CONST anz) 

PROC downety (TEXT CONST muster) 

PROC downety (TEXT CONST muster, INT CONST anz) 

PROC uppety (TEXT CONST muster) 

PROC uppety (TEXT CONST muster, INT CONST anz) 

OP C (TEXT CONST old, new) 

OP C (TEXT CONST replacement) 

PROC change to (TEXT CONST old, new) 

OP CA (TEXT CONST old, new) 



PROC 


change all fTEXT CONST old, 


BOOL 


PROC 


eof 


BOOL 


PROC 


mark 


PROC 


nark 


(BOOL CONST mark on) 


BOOL 


PROC 


at (TEXT CONST pattern) 


TEXT 


PROC 


word 


TEXT 


PROC 


word (TEXT CONST sep) 


TEXT 


PROC 


word (INT CONST len) 


PROC 


note 


(TEXT CONST text) 


PROC 


note 


(INT CONST number) 


PROC 


note 


line 


BOOL 


PROC 


anything noted 


PILE 


PROC 


note file 


PROC 


note 


edit (PILE VAR context) 


PROC 


note 


edit 



PACKET std transput : 

PROC sysout (TEXT CONST file name) 
TEXT PROC sysout 

PROC sysin (TEXT CONST file name) 

TEXT PROC sysin 

PROC put (TEXT CONST word) 

PROC put (INT CONST number) 

PROC put (REAL CONST number) 

PROC putline (TEXT CONST textline) 

PROC line 

PROC line (INT CONST times) 
PROC page 

PROC write (TEXT CONST word) 
PROC get (TEXT VAR word) 

PROC get (TEXT VAR word, TEXT CONST separator) 

PROC get (INT VAR number) 

PROC get (REAL VAR number) 

PROC get (TEXT VAR word, INT CONST length) 

PROC getline (TEXT VAR textline) 

PROC get secret line (TEXT VAR textline) 



PACKET local manager part 2 : 

PROC list 

PROC list (FILE VAR f) 



22-535 
22-547 
22-552 
22-557 
22-565 
22-57© 
22-578 
22-583 
22-587 
22-596 
22-613 
22-618 
22-623 
22-628 
22-633 
22-642 
22-646 
22-651 
22-656 
22-671 
22-677 
22-683 
22-689 
22-695 
22-701 
22-731 



23-33 

23-44 

23-48 

23-59 

23-64 

23-73 

23-79 

23-85 

23-94 

23-103 

23-112 

23-120 

23-130 

23-152 

23-175 

23-182 

23-189 

23-203 

23-217 



24-10 
24-22 
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PACKET eumel coder part 1 



PROC help (TEXT CONST proc name) 25-328 

PROC bulletin (TEXT CONST packet name) 25-559 

PROC bulletin 25-679 

PROC packets 25-701 

PROC run (TEXT CONST file name) 25-735 

PROC run 25-744 

PROC run again 25-748 

PROC insert (TEXT CONST file name) 25-756 

PROC insert 25-765 

PROC prot (TEXT CONST file name) 25-826 

PROC prot off 25-832 

BOOL PROC prot 25-837 

PROC check on 25-841 

PROC check off 25-845 

BOOL PROC check 25-849 

PROC warnings on 25-853 

PROC warnings off 25-857 

BOOL PROC warnings 25-861 

PACKET mathlib : 

REAL PROC pi 26-25 

REAL PROC e 26-26 

REAL PROC In (REAL CONST x) 26-28 

REAL PROC logl® (REAL CONST x) 26-32 

REAL PROC log2 (REAL CONST z) 26-36 

REAL PROC sqrt (REAL CONST z) 26-64 

REAL PROC exp (REAL CONST z) 26-83 

REAL PROC tan (REAL CONST x) 26-111 

REAL PROC tand (REAL CONST x) 26-116 

REAL PROC sin (REAL CONST x) 26-146 

REAL PROC sind (REAL CONST x) 26-154 

REAL PROC cos (REAL CONST x) 26-162 

REAL PROC cosd (REAL CONST x) 26-170 

REAL PROC arctan (REAL CONST y) 26-204 

REAL PROC arctand (REAL CONST x) 26-218 

REAL OP (REAL CONST b, e) 26-222 

REAL OP ♦* (REAL CONST a. INT CONST b) 26-231 

REAL PROC random 26-259 

PROC initializerandom (REAL CONST z) 26-263 

PACKET command handler : 

PROC get command (TEXT CONST command text) 27-33 

PROC get comffland (TEXT CONST command text, TEXT VAR command line) 27-39 
PROC analyze command (TEXT CONST command list, INT CONST permitted type, 
INT VAR command index, number of parans, 

TEXT VAR param 1, parara 2) 27-106 
PROC analyze command (TEXT CONST command list, command line, 

INT CONST permitted type, INT VAR command index, 

number of params, TEXT VAR param 1, parara 2) 27-117 

PROC do command 27-233 

PROC command error 27-247 

PROC cover tracks 27-266 

PROC cover tracks (TEXT VAR secret) 27-277 
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PACKET advertising : 



SOME PROC eumol must advertise S29-4 

PACKET tasks single : 

TYPE TASK 330-38 
TASK PROC myself 330-44 

OP (TASK VAR dest, TASK CONST source) 330-51 
BOOL OP = (TASK CONST left, right) 330-57 

BOOL PROC is niltask (TASK CONST t) 330-63 

INT PROC pet) (TASK CONST id, INT CONST field) 330-69 
INT PROC status (TASK CONST id) 330-75 
INT PROC channel (TASK CONST id) 330-81 
REAL PROC clock (TASK CONST id) 330-87 
INT PROC storage (TASK CONST id) 330-93 

PROC continue (INT CONST channel no) 330-112 
INT PROC dataspaces 330-121 



PACKET font store 



PROC font table (TEXT CONST new font table) 

TEXT PROC font table 

PROC list font tables 

PROC list fonts (TEXT CONST name) 

PROC list fonts 

INT PROC X step conversion (REAL CONST cm) 

REAL PROC X step conversion (INT CONST steps) 

INT PROC y step conversion (REAL CONST cm) 

REAL PROC y step conversion (INT CONST steps) 

TEXT PROC on string (INT CONST modification) 

TEXT PROC off string (INT CONST modification) 

INT PROC font (TEXT CONST font name) 

TEXT PROC font (INT CONST font number) 

BOOL PROC font exists (TEXT CONST font name) 

BOOL PROC next larger font exists (INT CONST font number, 

INT VAR next larger font) 
BOOL PROC next smaller font exists (INT CONST font number, 

INT VAR next smaller font; 
INT PROC font lead (INT CONST font number) 
INT PROC font height (INT CONST font number) 
INT PROC font depth (INT CONST font number) 
INT PROC indentation pitch (INT CONST font number) 
INT PROC char pitch (INT CONST font number, TEXT CONST char) 
INT PROC extended char pitch (INT CONST font number, TEXT CONST esc char, 

char) 

TEXT PROC replacement (INT CONST font number, TEXT CONST char) 
TEXT PROC extended replacement (INT CONST font number, 

TEXT CONST esc char, char) 
TEXT PROC font string (INT CONST font number) 
TEXT PROC y offsets (INT CONST font number) 
INT PROC bold offset (INT CONST font number) 

PROC get font (INT CONST font number, INT VAR indentation pitch, 

font lead, font height, font depth, 

ROW 256 INT VAR pitch table) 
PROC get replacements (INT CONST font number, TEXT VAR replacements, 
ROW 256 INT VAR replacements table) 



S31-88 

331-128 

331-135 

S31-164 

331-176 

331-218 

331-229 

331-237 

S31-248 

331-256 

S31-270 

331-284 

331-298 

S31-311 

331-318 

331-338 
331-358 
331-371 
S31-384 
331-397 
331-410 

331-43© 
331-452 

331-480 
331-537 
331-550 
331-563 



331-576 
331-595 



asqnrtlerta Objekte nach lUeton gaordnet 



PACKET basic archive : 



INT PROC block number 48-43 

PROC seek (INT CONST block) 48-47 

PROC rewind 48-51 

PROC skip dataspace 48-59 

PROC read (DATASPACE VAR ds) 48-70 

PROC read (DATASPACE VAR ds, INT CONST max pa^es, BOOL CONST error accept) 48-74 

PROC check read 48-118 

PROC write (DATASPACE CONST ds) 48-134 
PROC read block (DATASPACE VAR ds, INT CONST ds page no, 

INT CONST block no, INT VAR return code) 48-268 
PROC write block (DATASPACE CONST ds, INT CONST ds page no, 

INT CONST mode, INT CONST block no, INT VAR return code) 48-292 

INT PROC size (INT CONST key) 48-321 

INT PROC archive blocks 48-329 

PROC search dataspace (INT VAR ds pages) 48-333 

PROC format archive (INT CONST format code) 48-378 

PACKET archive single : 

PROC archive (TEXT CONST name) S49-72 

PROC release (TASK CONST t) S49-81 

PROC fetch (TEXT CONST file name) S49-215 

PROC fetch (TEXT CONST file name, TASK CONST from) S49-22i 

PROC erase S49-308 

PROC erase (TEXT CONST file name) S49-314 

PROC erase (TEXT CONST file name, TASK CONST dest) S49-320 

PROC save S49-411 

PROC save (TEXT CONST file name) S49-417 

PROC save (TEXT CONST file name, TASK CONST to) S49-423 

PROC check (TEXT CONST name, TASK CONST from) S49-534 

BOOL PROC exists (TEXT CONST name, TASK CONST from) S49-563 

PROC list (TASK CONST from) S49-576 

PROC list (PILE VAR list file, TASK CONST from) S49-588 

THESAURUS OP ALL (TASK CONST from) S49-649 

PROC clear (TASK CONST dest) S49-678 

PROC format (INT CONST format code, TASK CONST dest) S49-722 

PROC fomat (TASK CONST dest) S49-740 

PACKET name set : 

THESAURUS OP * (THESAURUS CONST left, right) 39-32 

THESAURUS OP ^ (THESAURUS CONST left. TEXT CONST right) 39-47 

THESAURUS OP - (THESAURUS CONST left, right) 39-57 

THESAURUS OP - (THESAURUS CONST left, TEXT CONST right) 39-72 

THESAURUS OP / (THESAURUS CONST left, right) 39-81 

THESAURUS OP ALL (TEXT CONST file nane) 39-96 

THESAURUS OP SOME (THESAURUS CONST thesaurus) 39-105 

THESAURUS OP SOME (TASK CONST task) 39-130 

THESAURUS OP SOME (TEXT CONST file name) 39-136 

THESAURUS OP LIKE (THESAURUS CONST thesaurus. TEXT CONST pattern) 39-142 

THESAURUS PROC remainder 39-157 

PROC do (PROC (TEXT CONST) operate. THESAURUS CONST thesaurus) 39-163 
PROC do (PROC (TEXT CONST, TASK CONST) operate, THESAURUS CONST thesaurus. 

TASK CONST task) 39-199 
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OP riLLBY (THESAURUS VAR thesaurus, PILE VAR file) 39-237 

OP PILLBY (PILE VAR file, THESAURUS CONST thesaurus) 39-254 

OP riLLBY (TEXT CONST file name, THESAURUS CONST thesaurus) 39-267 

PROC fetch (THESAURUS CONST naraeset) 39-276 

PROC fetch (THESAURUS CONST nameset, TASK CONST task) 39-282 

PROC save (THESAURUS CONST nameset) 39-288 

PROC save (THESAURUS CONST nameset, TASK CONST task) 39-294 

PROC fetch all 39-30© 

PROC fetch all (TASK CONST manager) 39-306 

PROC save all 39-312 

PROC save all (TASK CONST manager) 39-318 

PROC forget (THESAURUS CONST nameset) 39-324 

PROC erase (THESAURUS CONST nameset) 39-33© 

PROC erase (THESAURUS CONST nameset, TASK CONST task) 39-336 

PROC insert (THESAURUS CONST nameset) 39-342 

PROC edit (THESAURUS CONST nameset) 39-348 

PACKET system info : 

PROC Usk status S40-34 

PROC storage info S40-45 

PROC help S40-61 

PROC help (PILE VAR help file) S40-71 

PACKET konfigurleren : 

PROC new configuration 52-39 

PROC flow (INT CONST nr, INT CONST dtype) 52-68 

PROC ysize (INT CONST channel, new size, INT VAR old size) 52-72 

PROC Input buffer size (INT CONST nr, size) 52-76 

PROC baudrate (INT CONST nr, rate) 52^1 

PROC bits (INT CONST channel, number, parity) 52-85 

PROC bits (INT CONST channel, key) 52-89 

PROC new type (TEXT CONST dtype) 52-105 

PROC link (INT CONST nr, TEXT CONST dtype) 52-142 

PROC enter outcode (INT CONST eumel code, ziel code) 52-156 

PR(X enter outcode (INT CONST eumel code, wartezeit, TEXT CONST sequenz) 52-178 

PROC enter outcode (INT CONST eumelcode, TEXT CONST wert) 52-194 

PROC enter incode (INT CONST elan code, TEXT CONST sequenz) 52-211 

PEWC cursor logic (INT CONST dlst, TEXT CONST pre, mid, post) 52-225 

PROC ansi cursor (TEXT CONST pre, mid, post) 52-231 

PROC cursor logic (INT CONST dist, modus, TEXT CONST pre, mid, post) 52-237 

PROC elbit cursor 52-247 

PACKET cxxifigurator single : 

PROC configurate S53-220 

PROC exec configuration S53-447 

PROC setup S53-453 

PACKET Single user monitor : 

PROC monitor S43-34 

PROC monitor (PROC init system) S43-40 

PROC set date S43-121 
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PROC shutup S43-182 

PROC save system S43-192 

PROC collect garbage blocks S43-202 

PROC flxpoint S43-208 

PROC set clock (REAL CONST time) S43-235 
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3. Ubersicht uber die exportierten Objekte alphabetisch geordnet: 



'(M)' vor der Paketnummer heiBt, daB dies Objekt nur im Multi-User vorhanden ist. 
'(S)' vor der Paketnummer heiBt, daB dies Objekt nur im Single -User vorhanden ist. 
•(T)' vor der Paketnummer heiBt, daB dies Objekt nur in einem System mit Textverar- 
beitung vorhanden ist. 

Die Paketnummer ergibt sich aus der Reihenfolge, in der die Pakete im Multi-User mit 
Textverarbeitung insertiert wurden. Bitte beachten Sie, daB diese Reihenfolge nicht der 
Insertierungsreihenfolge im Single -User entspricht. Der Quellcode der insertierten Pa- 
kete ist in Teil 4 nach Paketnummern sortiert. 



» (INT CX)NST times, TEXT CONST source) --> TEXT 3-109 

(INT CONST arg, exp) ~> INT 8-126 

(REAL CONST a, INT CONST b) — > REAL 26-231 

(REAL CONST b, e) — > REAL 26-222 

(TE:<T CONST p, INT CONST x) — > TEXT 15-58 

^ (TEXT CONST left, right) — > TEXT 3-103 

+ (THESAURUS CONST left, TEXT CONST right) — > THESAURUS 39-47 

+ (THESAURUS CONST left, right) — > THESAURUS 39-32 

- (TEXT CONST alphabet) — > TEXT 15-43 

- (THESAURUS CONST left, TEXT CONST right) — > THESAURUS 39-72 

- (THESAURUS CONST left, right) — > THESAURUS 39-57 
/ (THESAURUS CONST left, right) — > THESAURUS 39-81 
:= (DATASPACE VAR dest, DATASPACE CONST source) 5-23 
:= (FILE VAR left, FILE CONST right) 16-16© 
:= (INITFLAG VAR fla^, BOOL CONST flagtrue) 4-39 
:= (TASK VAR dest, TASK CONST source) S30-51 

(THESAURUS VAR dest, THESAURUS CONST source) 13-103 

= (TASK CONST left, right) — > BOOL S30-57 

A 

abschnitt neu (INT CONST von satznr, bis satznr) 21-2228 

ABS (INT CONST argument) — > lOT 8-122 

abs (INT CONST argument) ~> INT 8-114 

abs (REAL CONST value) — > REAL 10-329 

ABS (REAL CONST value) — > REAL 10-338 

aktueller editor — > INT 21-1279 

aktueller editor ~> INT 21-2158 

ALIGN 5-21 

alles neu 21-2261 

ALL (TASK CONST from) — > THESAURUS S49-649 

ALL (TEXT CONST file name) — > THESAURUS 39-96 

all — > THESAURUS 14-358 
analyze command (TEXT CONST command list, command line, 

INT CONST permitted type, INT VAR command index, 

number of pararas, TEXT VAR param 1, param 2) 27-117 
analyze command (TEXT CONST command list, INT CONST permitted type, 
INT VAR command index, number of params, 

TEXT VAR param 1, param 2) 27-106 

AND (INT CONST left, right) — > INT 2-23 

ansi cursor (TEXT CONST pre, mid, posti 52-231 

any (INT CONST n) — > TEXT 15-64 
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any (INT CONST n, TEXT CONST a) ~> TEXT 15-72 

any — > TEXT 15-62 

any (TEXT CONST a) — > TEXT 15-7© 

anything noted — > BOOL 22-689 

archive blocks — > INT 48-329 

archive (TEXT CONST name) S49-72 

arctand (REAL CONST x) — > REAL 26-218 

arc tan (REAL CONST y) — > REAL 26-204 

at (FILE CONST f, TEXT CONST word) — > BOOL 16-1831 

at (TEXT CONST pattern) — > BOOL 22-642 



B 



baudrate (INT CONST nr, rate) 52-81 

begin list 14-237 

bildabschnitt neu (INT CONST von zeile, bis zeile) 21-2237 

bild neu 21-2249 

bild neu (PILE VAR t) 21-2251 

bild zeigen 21-2417 

bit (INT CONST bits, bit no; ~> BOOL 2-35 

bits (INT CONST channel, key) 52-89 

bits (INT CONST channel, number, parity) 52-85 
blockln (BATASPACE VAR ds, INT CONST page nr, codel, code2, 

INT VAR return code) 5-68 

blockin (ROW 256 INT VAR block, INT CONST codel, code2, 

INT VAR return code) 6-161 

block number — > INT 48-43 

blockout (BATASPACE CONST ds, INT CONST page nr, codel, code2, 

INT VAR return code) 5-63 
blockout (ROW 256 INT CONST block, INT CONST codel, code2, 

INT VAR return code) 6-146 

bold offset (INT CONST font number) — > INT S31-563 

bound — > TEXT 15-87 

bulletin 25-679 

bulletin (TEXT CONST packet name) 25-559 



c 



CA (TEXT CONST old, new) 




22-613 


cat input (TEXT VAR t, esc char) 




6-113 


CAT (TEXT VAR result, INT CONST number) 




3-374 


CAT (TEXT VAR right, TEXT CONST left) 




3-99 


change all (TEXT CONST old, new) 




22-618 


change (FILE VAR f, INT CONST from, to, TEXT 


CONST new) 


16-1946 


change (TEXT VAR destination, INT CONST from, 


to, TEXT CONST new) 


3-167 


change (TEXT VAR destination, TEXT CONST old, 


, new) 


3-183 


change to (TEXT CONST old, new) 




22-596 


channel — > INT 




6-133 


channel (TASK CONST id) ~> INT 




S30-^l 


char pitch (INT CONST font number , TEXT CONST 


char) ~> INT 


S31-410 


check — > BOOL 




25-849 


check off 




25-845 


check on 




25-841 


check read 




48-118 


check (TEXT CONST name, TASK CONST from) 




S49-534 


clear error 




9-44 


clear removed (FILE VAR f) 




16-1687 


clear (TASK CONST dest) 




S49-678 
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clock (INT CONST nr) --> REAL 4-62 

clock (TASK CONST id) — > REAL S30-87 

close (FILE VAR f) 16-983 

code (INT CONST code) ~> TEXT 3-53 

code (TEXT CONST text) ~> INT 3-49 

col (FILE CONST f) — > INT 16-1795 

col (PILE VAR f, Iirr CONST new column) 16-18©1 

col -> INT 22-453 

col (INT CONST stelle) 22-448 

collect garbage blocks S43-202 

collect heap garbage 3-24© 

command dialogue — > BOOL 12-36 

command dialogue (B(X)L CONST status) 12-4© 

command error 27-247 

compress (TEXT CONST text) ~> TEXT 3-144 

concatenate line (FILE VAR f, BOOL CONST delete blanks) 16-14©7 

configurate S53-220 

CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name) — > BOOL 13-231 

continue (INT CONST channel no) S30-112 

continue scan (TEXT CONST scan text) 18-44 

control (INT CONST codel, code2, code3, INT VAR return code) 6-142 

copy attributes (FILE CONST source file, PILE VAR dest file) 16-17©3 

copy (DATASPACE CONST source, TEXT CONST dest name) 14-2©® 

copy (TEXT CONST source name, dest name) 14-218 

cosd (REAL CONST x) — > REAL 26-17© 

cos (REAL CONST x) ~> REAL 26-162 

cout (INT CONST number) 6-128 

cover tracks 27-266 

cover tracks (TEXT VAR secret) 27-277 

create (TEXT CONST name) 14-61 

C (TEXT CONST old, new) 22-583 

C (TEXT CONST replacement) 22-587 

cursor (INT CONST x, y) 6-118 

cursor logic (INT CONST dist, modus, TEXT CONST pre, raid, post) 52-237 

cursor logic (INT CONST dist, TEXT CONST pre, mid, post) 52-225 

D 

dataspaces — > INT S3©-121 

date (REAL CONST datum) — > TEXT 11-44 

date ~> TEXT 11-33 

date (TEXT CONST datura) — > REAL 11-2®1 

day — > REAL 11-28 

day (REAL CONST datum) ~> TEXT 11-128 

decimal exponent (REAL CONST mantissa) ~> INT 10-48 

DECR (REAL VAR dest, REAL CONST decrement) l©-393 

delete char (TEXT VAR string, INT CONST delete pos) 3-214 

delete int (TEXT VAR result, INT CONST delete pos) 3-385 

delete record (PILE VAR f) 16-1055 

delete (THESAURUS VAR thesaurus, INT CONST index) 13-188 

delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) 13-180 

D (INT CONST anz) 22-498 

disable stop 9-32 

display (TEXT CONST text) 6-81 

do conmand 27-233 

do (PROG (TEXT CONST) operate, THESAURUS CONST thesaurus) 39-163 
do (PROC (TEXT CONST, TASK CONST) operate, THESAURUS CONST thesaurus, 

TASK CONST task) 39-199 

do (TEXT CONST command) 17-23 
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downety (PILE VAR f, TKXT CONST pattern.) 16-1884 

. downety (FILE VAR f, TEXT CONST pattern, INT CONST max line) 16-189© 

downety (TEXT CONST muster) 22-557 

downety (TEXT CONST muster, INT CONST anz) 22-565 

down (FILE VAR f) 16-1071 

down (FILE VAR f, INT CONST n) 16-1085 

down (PILE VAR f, TEXT CONST pattern) 16-1869 

down (FILE VAR f, TEXT CONST pattern, INT CONST max lino) 16-1875 

down (INT CONST anz) 22-493 

down (TEXT CONST muster) 22-513 

down (TEXT CONST muster, INT CONST anz) 22-53© 

ds pa«es (DATASPACE CONST ds) — > INT 5-51 

D (TEXT CONST muster) 22-525 

E 

edit 22-20® 

editfile — > PILE 21-2929 

edit (FILE VAR f) 22-176 

edit (FILE VAR f, INT CONST x, y, x size, y size) 22-186 

edit (PILE VAR f, TEXT CONST res, PROC ; TEXT CONST) kdo interpreter) 22-193 

editget command (BOOL CONST schalter) 21-81 

editget (TEXT VAR editsatz) 21-200 

editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge) 21-205 
editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge, 

TEXT CONST sep, res, TEXT VAR exit char) 21-87 

editget (TEXT VAR editsatz, INT CONST editlimit, TEXT VAR exit char) 21-192 

editget (TEXT VAR editsatz, TEXT CONST sep, res, TEXT VAR exit char) 21-196 

edit info (FILE CONST f) ~> INT 16-176© 

edit info (PILE VAR f, INT CONST info) 16-1767 

edit (INT CONST i) 22-261 

edit (INT CONST i, TEXT CONST res, PROC (TEXT CONST) kommando interpreter) 21-2665 
edit (INT CONST von, bis, start, TEXT CONST res, PROC 

(TEXT CONST) kommando interpreter) 21-267© 

edit (TEXT CONST filename) 22-233 

edit (TEXT CONST filename, INT CONST x, y, x size, y size) 22-250 

edit (THESAURUS CONST najneset) 39-348 

elbit cursor 52-247 

empty thesaurus ~> THESAURUS 13-96 

enable stop 9-28 

enter Incode (INT CONST elan code, TEXT CONST sequenz) 52-211 

enter outcode (INT CONST eumelcode, TEXT CONST wert) 52-194 

enter outcode (INT CONST eumel code, wartezeit, TEXT CONST sequenz) 52-178 

enter outcode (INT CONST eumel code, ziel code) 52-156 

enter password (TEXT CONST file name, write pass, read pass) 14-284 

enter password (TEXT CONST password) 14-270 

eof — > BOOL 22-623 

eof (PILE CONST f) — > BOOL 16-1182 

erase S49-308 

erase (TEXT CONST file name) S49-314 

erase (TEXT CONST file name, TASK CONST dest) S49-320 

erase (THESAURUS CONST nameset) 39-330 

erase (THESAURUS CONST nameset, TASK CONST task) 39-336 

e ~> REAL 26-26 

error code ~> INT 9-79 

error line ~> INT 9-85 

error message ~> TEXT 9-72 

errorstop (INT CONST code» TEXT CONST message) 9-107 

errorstop (TEXT CONST message) 9-101 
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eumel niust advertise — > SOME S29-4 

exec configuration S53-447 

exec (PROC (TEXT VAR, INT CONST) proc, PILE VAR f, INT CONST i) 16-1853 

exec (PROC (TEXT VAR, TEXT CONST) proc, PILE VAR f, TEXT CONST t) 16-1844 

exists (TEXT CONST naLne) — > BOOL 14-127 

exists (TEXT CONST name, TASK CONST from) --> BOOL S49-563 

exp (REAL CONST z) ~> REAL 26-83 
extended char pitch (INT CONST font number, TEXT CONST esc char, char) 

— > INT S31-43© 
extended replacement (INT CONST font number, TEXT CONST esc char, char) 

— > TEXT S31-48© 

F 

false ~> BOOL 7-4 

fetch all 39-30© 

fetch all (TASK CONST manager) 39-306 

fetch (TEXT CONST file name) S49-215 

fetch (TEXT CONST file name, TASK CONST from) S49-221 

fetch (THESAURUS CONST nameset) 39-276 

fetch (THESAURUS CONST nameset, TASK CONST task) 39-282 

PILE 16-150 

riLLBY (PILE VAR file, THESAURUS CONST thesaurus) 39-254 

PILLBY (TEXT CONST file name, THESAURUS CONST thesaurus) 39-267 

PILLBY (THESAURUS VAR thesaurus, PILE VAR file) 39-237 

fixpoint S43-208 

floor (REAL CONST real) ~> REAL 10-62 

flow (INT CONST nr, INT CONST dtype) 52-68 

font depth (INT CONST font number) — > INT S31-384 

font exists (TEXT CONST font name) ~> BOOL S31-311 

font height (INT CONST font number) — > INT S31-371 

font (INT CONST font number) ~> TEXT S31-298 

font lead (INT CONST font number) — > INT S31-358 

font string (INT CONST font number) — > TEXT S31-537 

font table (TEXT CONST new font table) S31-88 

font table — > TEXT S31-128 

font (TEXT CONST font name) ~> INT S31-284 

forget 14-157 

forget (DATASPACE CONST dataspace) 5-31 

forget (TEXT CONST name) 14-134 

forget (TEXT CONST name, QUIET CONST q) 14-145 

forget (THESAURUS CONST naxneset) 39-324 

format archive (INT CONST format code) 48-378 

format (INT CONST format code, TASK CONST dest) S49-722 

format (TASK CONST dest) S49-740 

frac (REAL CONST value) — > REAL 10-369 

PRANGE 16-152 

G 

getcharety ~> TEXT 21-1208 

getchar (TEXT VAR zelchen) 21-1173 

get command (TEXT CONST command text) 27-33 

get command (TEXT CONST command text, TEXT VAR command line) 27-39 

get cursor (INT VAR x, y) 6-124 

get editcursor (INT VAR x, y) 21-1219 

get editline (TEXT VAR editline, INT VAR editpos, editmarke) 21-917 

get (FILE VAR f, INT VAR number) 16-1346 
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get (PILE VAR f, REAL VAR number) 16-1354 

get (FILE VAR f» TEXT VAR word) 16-1336 

get (PILE VAR f, TEXT VAR word, INT CONST max length) 16-1312 

get (PILE VAR f, TEXT VAR word, TEXT CONST separator) 16-1268 
get font (INT CONST font number, INT VAR indentation pitch, font lead, 

font height, font depth, ROW 256 INT VAR pitch table) S31-576 

get (INT VAR number) 23-175 

getline (FILE VAR f, TEXT VAR text) 16-1152 

getline (TEXT VAR textline) 23-203 

get list entry (TEXT VAR entry, status text) 14-244 

get (REAL VAR number) 23-182 

get replacements (INT CONST font number, TEXT VAR replacements, 

ROW 256 INT VAR replacements table) S31-595 

get secret line (TEXT VAR textline) 23-217 

get tabs (TILE CONST f, TEXT VAR tabs) 16-1746 

GET (TEXT CONST filename) 22-367 

get (TEXT VAR word) 23-13© 

get (TEXT VAR word, INT CONST length) 23-189 

get (TEXT VAR word, TEXT CONST separator) 23-152 

get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) 13-281 

get window (INT VAR x, y, x size, y size) 21-2935 

groesster editor — > INT 21-1281 

G (TEXT CONST filename) 22-438 

H 

headline (FILE CONST f) — > TEXT 16-1732 

headline (FILE VAR f, TEXT CONST head) 16-1739 

heap size (DATASPACE CONST ds) — > INT 5-43 

heap size — > INT 3-236 

help (PILE VAR help file) S40-71 

help S40-61 

help {TEXT CONST proc name) 25-328 

highest entry (THESAURUS CONST thesaurus) — > INT 13-323 

hour ~> REAL 11-29 

hour — > REAL 11-265 

I 

id (INT CONST no) ~> INT 4-7© 

incharety (INT CONST time limit) ~> TEXT 6-95 

incharety — > TEXT 6-91 

inchar (TEXT VAR character) 6^7 

INCR (REAL VAR dest, REAL CONST increment) 10-387 

Indentation pitch (INT CONST font number) ~> INT S31-397 

INITPLAG 4-19 

initialized (INITPLAG VAR fla^) — > BOOL 4-5© 

initialize random (INT CONST start) 8-197 

initializerandom (REAL CONST z) 26-263 

input buffer size (INT CONST nr, size) 52-76 

input (FILE VAR f) 16-962 

input ~> TRANSPUTDIRECTION 16-851 

insert 25-765 

insert char (TEXT VAR string, TEXT CONST char, INT CONST insert pes) 3-224 

insert int (TEXT VAR result, INT CONST insert pos, number) 3-379 

insert record (FILE VAR f) 16-1063 

insert (TEXT CONST file name) 25-756 

Insert (THESAURUS CONST naraeset) 39-342 
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insert (THESAURUS VAR thesaurus, TEXT CONST name) 13-170 

insert (THESAURUS VAR thesaurus, TEXT (X)NST name, INT VAR index) 13-111 

int (REAL CONST value) — > INT 10-399 

int (TEXT CONST number) ~> INT 8-38 

is editget ~> BOOL 21-913 

is error — > B(X)L 9-40 

is first record (TILE CONST f) ~> BOOL 16-1174 

is incharety (TEXT CONST muster) ~> BOOL 21-1194 

is kanji esc (TEXT CONST char) — > BOOL 21-947 

is nlltask (TASK CONST t) — > BOOL S30-63 

ISUB (TEXT CONST text, INT CONST index) ~> INT 3-57 



ke 4-74 
kommando auf taste legen (TEXT CONST taste, kommando) 20-71 
komroando auf taste (TEXT CONST taste) — > TEXT 20-79 



L 



last conversion ok — > BOOL 8-170 

last param — > TEXT 12-101 

last param (TEXT CONST new) 12-114 

len (FILE CONST f) — > INT 16-1930 

LENGTH (TEXT CONST text) — > INT 3-124 

length (TEXT CONST text) — > INT 3-120 

len — > INT 22-443 

lernsequenz auf taste legen (TEXT CONST • taste, lernsequenz) 20-27 

lernsequenz auf taste (TEXT CONST taste) — > TEXT 20-63 

LEXE<5UAL (TEXT CONST left, right) ~> BOOL 3-262 

LEXGREATEREQUAL (TEXT CONST left, right) ~> BOOL 3-276 

LEXGREATER (TEXT CONST left, right) ~> BOOL 3-269 

lex sort (TEXT CONST datelname) 16-2025 

lex sort (TEXT CONST datelname, INT CONST sortieranfang) 16-2029 

LIKE (TEXT CONST t, pattern) — > BOOL 15-193 

LIKE (THESAURUS CONST thesaurus. TEXT CONST pattern) ~> THESAURUS 39-142 

limit ~> INT 22-463 

limit (INT CONST limit) 22-458 

line 23-94 

line (TILE VAR f) 16-1119 

line (TILE VAR f, INT CONST lines) 16-1145 

line (INT CONST times) 23-103 

line no (FILE CONST f) — > INT 16-1197 

line no — > INT 22-473 

lines (FILE CONST f) — > INT 16-1774 

lines — > INT 22-468 

line type (FILE CONST f) ~> INT 16-1210 

line type (FILE VAR f, INT CONST t) 16-1204 

link (INT CONST nr. TEXT CONST dtype) 52-142 

link (THESAURUS CONST thesaurus, TEXT CONST name) ~> INT 13-267 

list 24-10 

list (FILE VAR f) 24-22 

list (FILE VAR list file, TASK CONST from) S49-588 

list fonts S31-176 

list fonts (TEXT CONST name) S31-164 

list font tables S31-135 

list (TASK CONST from) S49-576 

In (REAL CONST x) — > REAL 26-28 
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logl© (REAL CONST x) — > REAL 26-32 

log2 (REAL CONST z) — > REAL 26-36 

lowest reset (INT CONST bits) — > INT 2-65 

lowest set (INT CONST bits) — > INT 2-53 



M 



margin — > INT 21-2630 

margin (INT CONST i) 21-2632 

mark ~> BOOL 22-628 

mark (BOOL CONST mark on) 22-633 

mark col (FILE CONST f) -> INT 16-1982 

mark (FILE CONST f) — > BOOL 16-1956 

mark (FILE VAR f, INT CONST line no, col) 16-1962 

mark line no (FILE CONST f) ~> INT 16-1973 

mark refresh line mode — > BOOL 19-24 

mark refresh line mode (BOOL CONST b) 19-28 

marksize ~> INT 19-13 

marksize (INT CONST i) 19-19 

matchend (INT CONST x) — > INT 15-97 

match (INT CONST x) ~> TEXT 15-91 

matchpos (INT CONST x) — > int 15-95 

max (INT CONST first, second) — > INT 8-160 

maxint ~> INT 8-9 

max line length (FILE CONST f) — > INT 16-1716 

max line length (FILE VAR f, INT CONST new limit) 16-1723 

max (REAL CONST a, b) — > REAL 10-375 

max real — > REAL 10-4© 

max text length — > INT 3-35 

min (INT CONST first, second) —> INT 8-154 

minint ~> INT 8-7 

min (REAL CONST a, b) — > REAL 10-381 

minute — > REAL 11-30 

modify (FILE VAR f) 16-976 

modify — > TRANSPUTDIRECTION 16-861 

MOI (INT CONST left, right) — > INT 8-95 

MOD (REAL CONST left, right) — > REAL 10-359 

monitor (PROG init system) S43-40 

monitor S43-34 

month (REAL CONST datum) — > TEXT 11-139 

myself ~> TASK S30-44 



N 



name 


(THESAURUS CONST thesaurus, INT CONST index) ~> TEXT 




13-274 


new 


configuration 




52-39 


new 


(TEXT CONST name) — > DATASPACE 




14-86 


new 


type (TEXT CONST dtype) 




52-105 


next 


ds page (DATASPACE CONST ds, INT CONST pa^e nr) — > INT 




5-59 


next 


larger font exists (INT CONST font number, INT VAR 


next 


larger font) 




~> BOOL 




S31-318 


next 


smaller font exists (INT CONST font number, INT VAR 


next 


smaller font) 




~> BOOL 




S31-338 


next 


symbol (FILE VAR f, TEXT VAR symbol) 




18-303 


next 


symbol (FILE VAR f, TEXT VAR symbol, INT VAR type) 




18-312 


next 


symbol (TEXT VAR symbol) 




18-52 


next 


symbol (TEXT VAR symbol, INT VAR type) 




18-59 


nichts neu 




21-2217 
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nilspace — > lATASPACE 5-27 

no do again 17-44 

note edit 22-731 

note edit (TILE VAR context) 22-701 

note file — > FILE 22-695 

note (INT CONST number) 22-677 

note line 22-683 

note (TEXT CONST text) 22-671 

no (TEXT CONST question) — > BOOL 12-81 

notion (TEXT CONST t, INT CONST r) — > TEXT 15-765 

notion (TEXT CONST t) — > TEXT 15-78 

o 

off string (INT CONST modification) — > TEXT S31-270 

old (TEXT CONST name) — > DATASPACE 14-96 

old (TEXT CONST name, INT CONST expected type) — > DATASPACE 14-11© 

online — > BOOL 6-137 

on string (INT CONST modification) —> TEXT S31-256 

open editor (FILE CONST new file, BOOL CONST access) 21-2753 
open editor (INT CONST editor nr, FILE CONST new file, B(X)L CONST access, 

INT CONST X start, y, x len start, y len) 21-2792 

open editor (INT CONST i) 21-2881 

OR (INT CONST left, riglit) — > INT 2-27 

OR (TEXT CONST a, b) — > TEXT 15-54 

output (FILE VAR f) 16-969 

output ~> TRANSPUTDIRECTION 16^56 

outsubtext (TEXT CONST source, INT CONST from) 6-39 

outsubtext (TEXT CONST source, INT CONST from, to) 6-43 

out (TEXT CONST text) 6-35 

outtext (TEXT CONST source, INT CONST from, to) 6-47 

P 

packets 25-701 

page 23-112 

param position (INT CONST x) 12-95 

pattern found ~> BOOL 16-674 

pause 6-105 

pause (INT CONST time limit) 6-100 

pcb (INT CONST field) — > INT 4-26 

pcb (TASK CONST id, INT CONST field) ~> INT S30-69 

pi — > REAL 26-25 

pos (FILE CONST f, TEXT CONST pattern. INT CONST i) — > INT 16-1861 

pos (TEXT CONST source, low, high, INT CONST from) — > INT 3-140 

pos (TEXT CONST source, pattern) — > INT 3-128 

pos (TEXT CONST source, pattern, INT CONST from) ~> INT 3-132 

pos (TEXT CONST source, pattern, INT CONST from, to) ~> INT 3-136 

prefix (TEXT CONST pattern) — > TEXT 16-546 

prot ~> BOOL 25-«37 

prot off 25-832 

prot (TEXT CONST file name) 25-826 

P (TEXT CONST filename) 22-362 

push (TEXT CONST ausfuehrkommando) 21-991 

put editline (TEXT CONST editline, INT CONST editpos, editmarke) 21-925 

put error 9-116 

put (FILE VAR f, INT CONST value) 16-1236 

put (FILE VAR f, REAL CONST real) 16-1243 
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put (PILE VAR f, TEXT CONST word) 16-1217 

put (INT CX)NST number) 23-73 

put line (TILE VAR f, TEXT CONST word) 16-1045 

putline (TEXT CONST textline) 23-85 

put (REAL CONST number) 23-79 

put tabs (TILE VAR f, TEXT CONST tabs) 16-1753 

PUT (TEXT CONST filename) 22-293 

put (TEXT CONST word) 23-64 



<5UIET 

quiet ~> 
quit 

quit last 



QUIET 



12-29 
12-31 
21-2153 
21-2144 



R 



random (INT CONST lower bound, upper bound) — > INT 3-208 

random — > REAL 26-259 
read block (DATASPACE VAR ds, INT CONST ds page no, lOT CONST block no, 

INT VAR return code) 48-268 

read (MTASPACE VAR ds) 48-7© 

read (LATASPACE VAR ds, INT CONST max pages, BOOL CONST error accept) 48-74 

read password ~> TEXT 14-263 

read permission (TEXT CONST name, supply password) — > BOOL 14-312 

read record (PILE CONST f, TEXT VAR record) 16-1111 

real (INT CONST value) — > REAL 10-424 

real (TEXT CONST text) — > REAL 10-243 

reinsert (TILE VAR f) 16-1695 

release (TASK CONST t) S49-81 

remainder — > THESAURUS 39-157 

removed lines (PILE CONST f) —> INT 16-1781 

remove (FILE VAR f, INT CONST size) 16-1679 

rename (TEXT CONST old name, new name) 14-224 

rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) 13-248 

rename (THESAURUS VAR thesaurus, TEXT CONST old, new) 13-242 

replacement (INT CONST font number, TEXT CONST char) ~> TEXT S31-452 

replace (TEXT VAR dest, INT CONST pos, TEXT CONST source) 3-74 

replace (TEXT VAR text. INT CONST index, REAL CONST code) 3-69 

replace (TEXT VAR text, INT CONST index, value) 3-61 

reset bit (INT VAR bits, INT CONST bit no) 2-47 

reset (FILE VAR f) 16-926 

reset (PILE VAR f, TRANSPUTDIRECTION CONST mode) 16-935 

reset range (PILE VAR f) 16-1668 

rewind 48-51 

rotate (INT VAR bits, INT CONST number of bits) 2-19 

round (REAL CONST real, INT CONST digits) — > REAL 10-66 

RSUB (TEXT CONST text, INT CONST index) — > REAL 3-65 

rubin mode — > BOOL 21-2653 

rubin node (INT CONST editor nr) — > BOOL 21-2655 

run 25-744 

run again 25-748 

run (TEXT CONST file name) 25-735 
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s 



satznr neu 




21-2219 


satznr zeigen 




21-227© 


save all 




39-312 


save all (TASK CONST manager) 




39-318 


save 




S49-411 


save system 






save (TEAT tXJNST nie name) 




S49-417 


/ TT* VT O^MC'T' *i TACIT fV^ktCT ♦^X 

save (TEAT CONST nie name, task const to; 




S4y-4co 


save (THESAURUS CONST naineset; 




39-288 


save (THESAURUS CONST nameset, task const tasKy 




39-294 


say (TEXT CONST message) 




IC-O f 


^^^^ 1 T^TT V tf 

scan (FILE VAR f) 




18-296 


scan (TEXT CONST scan text) 




18-36 


search dataspace (INT VAR ds pa^es) 




48-333 


second — > REAL 




11-31 


SeeX (INl (^NSl DIOCK) 




48-47 


segments (TILE CONST T) — > INT 




16-1788 


sequential file ( inANSrUiillnEl^iiON CONbi mode, HAlAbrAuE UUNbi dSj - 


V PTT f 
— > 1 likE 


iD-ooy 


sequential rile ( TRANSPUTJjIRECTION CONST mode, TEXT CCMiST name) — > 


FILE 


16-885 


session — > INT 




4-22 


set Dlt (INT VAR DltS» INT CONST Dlt no) 




2-41 


set busy indicator 




21-2508 


set clock (REAL CONST time) 




S43-235 


set conversion (BOOL CONST success) 




8-174 


set date 




S43-121 


set exp (INT CONST e>:ponent, REAL VAR number) 




10-52 


set line nr (INT CONST value) 




4-34 


set mariced range (rlLE VAR r, rRAriGE VAR old range) 




16-1993 


set range (PILE VAR f, FRANCE VAR new range) 




16-1620 


set range (FILE VAR f, INT CONST start line, start col. 






FRANCE VAR old range) 




16-1550 


setup 




S53-453 


show 




22-283 


show (FILE VAR f) 




22-266 


show (TEXT CONST iilename) 




22-273 


shutup 




S43-ld2 


SIGN (INT CONST argument) — > INT 




8-110 


sign (INT CONST argument) — > INT 




8-101 


Sign (REAL CONST value) — > INT 




10-344 


SIGN (tlEAL CONST value) — > INT 




10-353 


sind (REAL CONST x) — > REAL 




26-154 


sin (ElEAL CONST x) — > REAL 




26-146 


size (INT CONST key) — > INT 




48-321 


SAi.p a&b&space 




48-59 


small real — > ElEAL 




10-42 


somefix (TEXT CONST pattern) ~> TEXT 




15-123 


SOME (TASK CONST task) — > THESAURUS 




39-130 


SOME (TEXT CONST file name) — > THESAURUS 




39-136 


SOME (THESAURUS CONST thesaurus) —> THESAURUS 




39-105 


sort (TEXT CONST dateiname) 




16-2016 


sort (TEXT CONST dateiname, INT CONST sortieranfang) 




16-2020 


split line (FILE VAR f, INT CONST split col) 




16-1365 



split line (FILE VAR f, INT CONST split col, BOOL CONST note indentation) 16-1371 

sqrt (REAL CONST z) ~> REAL 26-64 

status (INT CONST pos, TEXT CONST status pattern) 14-187 

status (TASK CONST id) ~> INT S30-75 

status (TEXT CONST name, status text) 14-166 

status (TEXT CONST name) ~> TEXT 14-176 
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std kommando interpreter (TEXT CONST taste) 22-58 

std taste nbelegung 20-92 

std ~> TEXT 12-118 

stop 9-135 

storage (DATASPACE CONST ds) — > INT 5-47 

storage info S40-45 

s-orage (INT VAR size, used) 4-66 

storage (TASK CONST id) ~> INT S30-93 
stranalyze (ROW 256 INT CONST table, INT VAR sum, INT CONST max sum, 
TEXT CONST string, INT VAR index, INT CONST to, 

INT VAR exit code) 3-244 

SUB (TEXT CONST text, INT CONST pos) — > TEXT 3-37 

subtext (TILE CONST f, INT CONST from, to) ~> TEXT 16-1938 

subtext (TEXT CONST source, INT CONST from) — > TEXT 3-45 

subtext (TEXT CONST source, INT CONST from, to) — > TEXT 3-41 

sysin ~> TEXT 23-59 

sysin (TEXT CONST file name) 23-48 

sysout ~> TEXT 23-44 

sysout (TEXT CONST file name) 23-33 

T 

tand (REAL CONST x) ~> REAl 26-116 

tan (REAL CONST x) — > REAL 26-111 

TASK S30-38 

task status S40-34 

taste enthaelt kommando (TEXT CONST taste) ~> BOOL 20-87 

text (INT CONST number, length) — > TEXT 8-25 

text (INT CONST number) — > TEXT 8-12 

text (REAL CONST real, INT CONST length, fracs) — > TEXT 10-199 

text (REAL CONST real, INT CONST length) — > TEXT 10-155 

text (REAL CONST real) — > TEXT 10-88 

text (TEXT CONST source, INT CONST length, from) — > TEXT 3-95 

text (TEXT CONST source, INT CONST length) ~> TEXT 3-78 

THESAURUS 13-17 

time of day (REAL CONST value) — > TEXT 11-170 

time of day ~> TEXT 11-166 

time (REAL CONST value, INT CONST length) ~> TEXT 11-178 

time (REAL CONST value) — > TEXT 11-174 

TIMESOUT (INT CONST times, TEXT CONST text) 6-59 

time (TEXT CONST time) — > REAL 11-260 

T (INT CONST satz nr) 22-488 

to eof (TILE VAR f) 16-1038 

to first record (FILE VAR f) 16-1031 

to line (TILE VAR f. INT CONST destination line) 16-1023 

to line (INT CONST satz nr) 22-478 

true ~> BOOL 7-4 

two bytes ~> BOOL 21-952 

two bytes (BOOL CONST new mode) 21-954 

type (DATASPACE CONST ds) — > INT 5-39 

type (DATASPACE CONST ds, INT CONST type) 5-35 

type (TEXT CONST ausf uehrkommando ) 21-1009 

u 

ueberschrift neu 21-2221 

ueberschrlft zeigen 21-2274 

U (INT CONST anz) 22-508 
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UNLIKE (TEXT CONST t, p) ~> BOOL 15-191 

up (TILE VAR f) 16-1078 

up (FILE V/^B. f, INT CONST n) 16-1091 

up (FILE VAR f, TEXT CONST pattern) 16-1899 

up (FILE VAR f, TEXT CONST pattern, INT CONST max line) 16-1905 

up (INT CONST anz) 22-503 

uppety (FILE VAR f, TEXT CONST pattern) 16-1914 

uppety (FILE VAR f, TEXT CONST pattern, INT CONST max line) 16-1920 

uppety (TEXT CONST muster) 22-570 

uppety (TEXT CONST muster, INT CONST anz) 22-578 

up (TEXT CONST muster) 22-535 

up (TEXT CONST muster, INT CONST anz) 22-552 

U (TEXT CONST muster) 22-547 

W 

warnings — > BOOL 25-861 

warnings off 25-857 

warnings on 25-853 

within kanji (TEXT CONST satz, INT CONST stelle) ~> BOOL 21-933 

word (FILE CONST f, INT CONST max length) — > TEXT 16-1825 

word (FILE CONST f) — > TEXT 16-1809 

word (FILE CONST f, TEXT CONST delimiter) — > TEXT 16-1815 

word (INT CONST len) — > TEXT 22-656 

word — > TEXT 22-646 

word (TEXT CONST sep) ~> TEXT 22-651 

word wrap — > BOOL 21-2623 

word wrap (BOOL CONST b) 21-2607 
write block (DATASPACE CONST ds, INT CONST ds page no, INT CONST mode, 

INT' CONST block no , INT VAR return code ) 48-292 

write (DATASPACE CONST ds) 48-134 

write (FILE VAR f, TEXT CONST word) 16-1250 

write password — > TEXT 14-257 

write permission ~> BOOL 21-989 

write permission (TEXT CONST name, supply password) ~> BOOL 14-335 

write record (FILE VAR f, TEXT CONST record) 16-1098 

write (TEXT CONST word) 23-120 

X 

XOR (BOOL CONST left, right) — > BOOL 7-7 

XOR (INT CONST left, right) ~> INT 2-31 

xsize — > INT 19-9 

xslze (INT CONST 1) 19-15 

X step conversion (INT CONST steps) ~> REAL S31-229 

X step conversion (REAL CONST cm) — > INT S31-218 

Y 

year (REAL CONST datura) — > TEXT 11-156 

yes (TEXT CONST question) ~> BOOL 12-45 

y offsets (INT CONST font number) — > TEXT S31-550 

yslze ~> INT 19-11 

ysize (INT CONST channel, new size, INT VAR old size) 52-72 

ysize (INT CONST i) 19-17 

y step conversion (INT CONST steps) — > REAL S31-248 

y step conversion (REAL CONST cm) ~> INT S31-237 



exportlerte Objekta alpbabetlscli goordnot 



z 

zeile neu 



21-2223 
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4. Quellecode der insertierten Pakete 

'(M)' vor der Paketnummer heiSt, daB dies Objekt nur im Multi - User vorhanden ist. 
'(S)' vor der Paketnummer heiBt. daB dies Objekt nur im Single - User vorhanden ist. 
'(T)' vor der Paketnummer heiBt. daB dies Objekt nur in einem System mit Textverar- 
beitung vorhanden ist. 

Die Paketnummer ergibt sich aus der Reihenfoige, in der die Pakete im Muiti - User mit 
Textverarbeitung insertiert wurden. Bitte beachten Sie. daB diese Reihenfoige nicht der 
insertierungsreihenfolge im Single -User entspricht. Der Quellcode der insertierten Pakete 
ist in Teit 4 nach Paketnummern sortiert. 
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1 "Standard-Schluesselwort kann nicht redef iniert werden" 


35 


1 "ungueltig als BOLD" 


36 


!"'{' fehlt" 


37 


1 "CONST bzw VAR nicht bei Strukturfeldern" 


38 


1"'=' fehlt" 
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56 
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1"')' fehlt" 
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63 I "undef inierte ROW Groesse" 

64 r'Typ Deklarationen nur im Paketrumpf* 

65 r'CONST bzw. V.^R ohne Zusamirenhang" 

66 Tist nicht deklariert, stent aber in der Paket-Schnitts telle*' 

I "ist nicht deklariert" 

68 r'unbekanntes Kommando" 

69 TTHIS IS NO CORRECT EXTERNAL NUMBER." 
7© I "Schluesselwort unzulaessig" 

71 I "Name erwartet" 

72 |"Denoter erwartet" 

73 |"ENDPROC ohne Zusammenhang" 

74 |"ENDOP ohne Zusammenhang" 

75 I "Refinement ohne Zusammenhang" 

76 ["Delimiter zwischen Paket-Refinement und leklaration fehlt" 

77 I "unzulaessiges Selektor-Symbol (kein Name)" 

78 r'BOUND Schachtelungen unzulaessig" 

79 I "BOUND-Ob jekte unzulaessig als Parameter" 
30 |"Textende fehlt" 

81 I "TEXT-Denoter zu lang" 

82 I 

83 I "Denoter-Wert wird fuer diese Maschine zu gross" 

84 I "Compiler-Pehler, wenden Sie sich an Ihren Systemberater!" 

85 I "ist ein zusammenhangloses Schluesselwort" 

86 I"'::' nur fuer Initialisierungen, sonst ':='" 

87 I "welches Objekt soil verlassen werden?" 

88 |"du bist gar nicht innerhalb dieses Refinements" 

89 I "nur die eigene PROC / OP kann verlassen werden" 
9© TTHEN fehlt" 

91 |"n fehlt" 

92 I "BOOL-Ausdruck erwartet" 

93 |"ELSE-Teil ist notwendig, da ein Wert geliefert wird" 

94 I "INT-Ausdruck erwartet" 

95 I "or fehlt" 

96 |"Keine Typanpassung moeglich" 

97 r'CASE-Label fehlt" 

98 |"mindestens eine CASE-Anweisung geben" 

99 |"CASE-Label ist zu gross (skipped)" 

100 Tmehrfach definiertes CASE-Label" 

101 I "ungueltiges Zeichen nach CASE-Label" 

102 |"OTHER>VISE-Teil fehlt" 

103 I "ENE SELECT fehlt" 

104 r'rekursiver Aufruf eines Refinements" 

105 I" wird nicht benutzt" 

106 1"';' Oder Operator ('+','-',...) fehlt" 

107 I "undef inierter monadischer Operator" 

108 Tundef inierter dyadischer Operator" 

109 |"Auf die Feinstruktur des Typs kann man nicht mehr zugreifen" 

110 I "fuer diesen Typ nicht def inierter Selektor" 

111 I "INT, REAL, BOOL, TEXT koennen nicht selektiert werden" 

112 |"bei ROWs nur Subscription" 

113 I "nicht selektierbar" 

114 I "unzulaessiger Index fuer Subscription" 

115 j " ' [ ' ohne Zusammenhang" 

116 I"']' ohne Zusammenhang" 

117 I"']' nach Subscription fehlt" 

118 |"ungueltig zwischen Anweisungen" 

119 I "nur die letzte Anweisung eines Abschnitts darf einen Wert liefern" 
12© I "Der Paketrumpf kann keinen Wert liefern" 

121 |"anstelle des letzten Symbols wurde ein Operand erwartet" 

122 riDer Schleifenrumpf darf keinen Wert liefern" 

123 !"die Laufvariable muss eine JOT VAR seln" 

124 I "wird schon in einer aeusseren Schleife als Laufvariable benutzt" 
1/2 a 1/2 
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125 ITROM erwartet" 

126 rUPTO bzw DOWNTO fehlt" 

127 TREPEAT fehlt" 

128 TEND REP fehlx" 

129 I "die Ko.nstante darf nicht veraendert werden" 

13® ["in einer lOR-Schleife darf die Laufvariable nicht veraendert werden" 

131 I "falscher Typ des Pesultats" 

132 |"ist CONST, es wird aber ein VAR Parameter verlangt" 

133 I "unbekannte Prozedur" 

134 I "Parameter-Prozedur lief ert falsches Resultat" 

135 I "Anzahl bzw. Typen der Parameter sind falsch" 

136 |"unbekannte Parameter-Prozedur" 

137 |''aktuelle Parameter-Prozedur hat CONST-, formale hat VAR-Parameter" 

138 i"Kein Konstruktor moeglich, da die Peinstruktur hier unbekannt ist" 

139 ["zu wenig lelder angegeben" 

140 I "zu viele Pelder angegeben" 

141 Tunzulaessiger Trenner zwischen Peldern" 

142 rPeld hat falschen Typ" 

143 I "falsche Element-Anzahl im ROW-Konstruktor" 

144 |"Dieser Typ kann nicht noch mehr konkretisiert werden" 

145 i "BOUNI-Ob jekt zu gross" 

146 I 

147 |"VVarnung in Zeile " 

148 r Zeile " 

149 Tin Zeile " 

150 1" < > " 

151 I" TYPE undefiniert " 

152 I" MODE undefiniert " 

153 I "Parameter spezifiziert: " 

154 I "Parameter T}T){ en) sind: " 

155 I" B Code, " 

156 j" B Paketdaten generiert" 

157 rOperand: " 

158 |"Operanden: " 

159 I", " 

160 ["erwartet " 

161 r'gefunden " 

162 i" " 

163 I 

164 i(* 001 ») ENI 

165 |{» 002 ») ENDPACKET 

166 |(* 003 ENDOP 

167 |!,* 004 ») ENDOPERATOR 

168 |(» ©05 ») ENIPROC 

169 |(*0©6») EIIDPROCEDURE 
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17© »»»*MM»«M»»»«-»«»»*HH»-»«-»«M»»» { f » 007 * ) PACKET 

171 j (» ©03 ♦) OP 

172 |(» 009 ») OPERATOR 

173 I f » 010 * ) PROC 

174 |( » 011 PROCEDURE 

175 1^* ©12 ») ri 

176 |c ©13 ») EHDir 

177 j!* ©14 ») ENDREP 

178 |c ©15 ») ENIREPEAT 

179 !(♦ ©16 *) PER 

180 ! ( ♦ ©17 * ) ELir 

181 I ( » 018 * ) ELSE 

182 |(* 019 ») UNTIL 

183 I ; » 020 » ) CASE 

184 |(» 021 ♦) OTHERWISE 

185 |{» 022 ») ENDSELECT 

186 iU 023 ») INTERNAL 

187 |(» 024 ») DEFINES 

188 |(» 025 ») LET 

189 |(» 026 *) n'PE 
19© |(* 027 *) INT 

191 |i« ©28 ») REAL 

192 |(» ©29 ») DATASPACE 

193 |;» 030 •) TEXT 

194 I (• ©31 *) BOOL 

195 |(* ©32 •) BOUND 

196 |(» ©33 ROW 

197 |(» ©34 •) STRUCT 

198 |(» ©35 *) CONST 

199 |(» ©36 •) VAR 

2©© |(« ©37 INIT CONTROL •) INTERNAL 

201 |(« 038 •) CONCR 

202 !(• 039 *») REP 
2©3 I (♦ ©4© *.) REPEAT 
2©4 !(• ©41 •) SELECT 
2©5 |(» ©42 •) EXTERNAL 
2©6 |{» ©43 •) ir 

2©7 I (* ©44 *) THEN 

2©8 i(* 045 •) OP 

209 I i* ©46 ») POR 

210 !(• 047 ») PROM 

211 I ©48 ») UPTO 

212 |(» 049 ») DOWNTO 

213 !(» 050 •) WHILE 

214 |(» 051 •) LEAVE 

215 |(» 052 ») WITH 

216 I (• ©53 •) TRUE 

217 |(* 054 •) FALSE 

218 I ( • 055 • ) : : SBL : = INCR DECR 

219 |(» 056 •) + - * / DIV MOD 
22© I »* 

221 j AND 

222 I CAND 

223 I OR 

224 I COR 

225 I NOT 

226 I =<>>>=<<= 

227 |(«©40 •) MAIN 

228 |(»©43») ENDOiTILE 

229 I 
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230 a j PACKET a : 

231 I 

232 out IPROC out (TEXT CONST t) : 

233 I EXTERNAL 6© 

234 lENDPROC out ; 

235 1 

236 outtext IPROC out text (TEXT CONST t, INT CONST typ) : 

237 i INTE?;:iAL 257 ; 

238 I ir vyj> = typ 

239 I THEN out (t) 

240 I ri 

241 jENIPROC out text ; 

242 I 

243 outline |PROC out line (INT CONST typ) : 

244 I INTERNAL 258 ; 

245 I IF Vfp = typ 

246 i THEN out ( '''*13""10'"') 

247 I ri 

248 lENDPROC out line ; 

249 I 

250 lENDPACKET a ; 



251 
252 
253 
254 
255 
256 
257 
258 
259 
260 
261 
262 
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bits 



1 I 

2 bits >»<M»«MH>««MMHM> j PACKET bits DEFINES 

3 I 

4 1 AND , 

5 I OR , 

6 1 XOR , 

7 j bit , 

8 I lowest reset , 

9 I lowest set , 

10 I reset bit , 

11 I rotate , 

12 I set bit : 

13 I 

14 I LET bits per int « 16 ; 

15 I 

16 I ROW bits per int INT VAR bit mask := ROW bits per int INT: 

17 I 

+ 1 (1, 2, 4, 8. 16, 32, 64, 128, 256, 512, 1024, 2048, 4096»8192, 16364, -321 

+ I 67-1) ; 

18 I 

19 route |PROC rotate (INT VAR bits, INT CONST number of bits) : 

20 1 EXTERNAL 83 

21 lENDPROC rotate ; 

22 1 

23 AND I INT OP AND (INT CONST left, right) : 

24 I EXTERNAL 124 

25 lENDOP AND ; 

26 I 

27 OR I INT OP OR (INT CONST left, right) : 

28 I EXTERNAL 125 

29 lENDOP OR ; 

30 I 

31 XOR I INT OP XOR (INT CONST left, right) : 

32 I EXTERNAL 121 

33 lENDOP XOR ; 

34 I 

35 bit I BOOL PROC bit (INT CONST bits, bit no) : 

36 I 

37 I (bits AND bit mask (bit no+D) <> 0 

38 I 

39 lENDPROC bit ; 

40 I 

41 setbit I PROC set bit (INT VAR bits. INT CONST bit no) : 

42 I 

43 I bits ;= bits OR bit mask (bit no+1) 

44 I 

45 lENDPROC set bit ; 

46 I 

2/1 bits 2/1 
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47 resetbit |PROC reset bit (INT VAR bits, INT CONST bit no) : 

48 I 

49 I bits ;x bits XOR (bits AND bit mask (bit no+D) 
56 i 

51 lENDPRCX! reset bit ; 

52 I 

53 lowestset |INT PROC lowest set (INT CXWST bits) : 

54 I 

55 I INT VAR mask index ; 

56 I FOR mask index FROM 1 UFTO 16 REP 

57 I IF (bits AND bit mask (mask index)) <> 6 

58 I THEN LEAVE lowest set WITH mask index - 1 

59 I FI 
66 I PER ; 

61 I -1 

62 I 

63 lEMDFROC lowest set ; 

64 I 

65 lowestreset |INT PROC lowest reset (INT CONST bits) : 

66 I 

67 I INT VAR mask index ; 

68 I FOR mask index FROM 1 UPTO bits per int REP 

69 I IF (bits AND bit mask (mask index)) - 6 

76 * I THEN LEAVE lowest reset WITH mask index - 1 

71 I FI 

72 I PER ; 

73 I -1 

74 I 

75 lENDPROC lowest reset ; 

76 I 

77 lENDPACKET bits ; 



2/2 



bits 



2/2 



Zeile ELAN EUMEL 1.8 10.11.86 text 

1 |(> VERSION 3 06.03.86 ♦) 

2 text *HM«»»*»»»*HH»»*«H^*MMMMf I PACKET text DEFINES 

3 I 

4 I max text length , 

5 I SUB , 

6 I subtext , 

7 I text , 

8 I length , LENGTH , 

9 ! CAT , 
1© I * . 

11 I » , 

12 I replace , 

13 I change , 

14 I change all , 

15 i compress , 

16 1 pos , 

17 I code , 

18 I ISUB , 

19 I RSUB , 

2© I delete char , 

21 I insert char , 

22 I delete int , 

23 I insert int , 

24 I heap size , 

25 I collect heap garbage , 

26 I stranalyze , 

27 I LEXEQUAL , 

28 I LEXGREATER , 

29 I LEXGREATEREQUAL : 
3© I 

31 I 

32 I 

33 jTEXT VAR text buffer , tail buffer ; 

34 I 

35 I INT CONST max text length := 32000 ; 

36 I 

37 SUB I TEXT OP SUB (TEXT CONST text, INT CONST pos ) : 

38 I EXTERtiAL 48 

39 lENI OP SUB ; 

40 I 

41 subtext [TEXT PROC subtext (TEXT CONST source, IITT CONST from, to ): 

42 I EXTERNAL 49 

43 lENDPROC subte.xt ; 

44 I 

45 subtext [TEXT PROC subtext (TEXT CONST source, INT CONST from ) : 

46 I EXTERNAL 5© 

47 lENDPROC subtext ; 

48 I 

49 code I INT PROC code (TEXT CONST text) : 

5© I EXTERNAL 46 

51 I END PROC code ; 

52 I 
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53 code I TEXT PROC code (INT CONST code) : 

54 I EXTERNAL 47 

55 lENDPROC code ; 

56 I 



57 ISUB I INT OP ISUB (TEXT CONST text, INT CONST index) : 

58 I EXTERNAL 44 

59 lENIXDP ISUB ; 

60 I 



61 replace |PROC replace (TEXT VAR text, INT CONST index, value) : 

62 I EXTERNAL 45 

63 lENDPROC replace ; 

64 I 



65 RSUB I REAL OP RSUB (TEXT CONST text, INT CONST index) : 

66 I EXTERNAL 100 

67 lENDOP RSUB ; 

68 I 



69 replace |PROC replace (TEXT VAR text, INT CONST index, REAL CONST code) : 

7© I EXTERNAL 101 

71 jENDPROC replace ; 

72 1 

73 I 



74 replace |PROC replace (TEXT VAR dest, INT CONST pes, TEXT CONST source) : 

75 I EXTERNAL 51 

76 lENDPROC replace ; 
77 



78 text I TEXT PROC text (TEXT CONST source, INT CONST length ) 

79 I 

80 I IT length < LENGTH source 

81 I THEN text buffer := subtext (source,l, length) 

82 I ELSE text buffer := source ; 

83 I mit blanks auffuellen 

84 I PI ; 

85 I text buffer . 

86 I 

I 

87 mitblanksauffuellen |mit blanks auffuellen : 

88 I INT VAR i ; 

89 I rOR i PROM 1 UPTO length - LENGTH source REP 

90 I text buffer CAT " 

91 I PER . 

92 I 

93 lENDPROC text ; 

94 I 



95 text I TEXT PROC text (TEXT CONST source, INT CONST length, from) : 

96 I text ( subtext (source, from) , length ) 

97 lENDPROC text ; 
96 I 
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99 CAT I OP CAT (TEXT VAR right, TEXT CONST left ) : 

100 I EXTERNAL 52 

101 lENDOP CAT ; 

102 I 

103 * I TEXT OP + (TEXT CONST left, right) : 

104 I text buffer := left ; 

105 I text buffer CAT right ; 

106 I text buffer 

107 lENDOP ; 

108 I 

109 * I TEXT OP * (INT CONST times, TEXT CONST source ) : 

110 I 

111 I text buffer :» ; 

112 I INT VAR i ; 

113 I rOR i PROM 1 UPTO times REP 

114 I text buffer CAT source 

115 I PER ; 

116 I text buffer 

117 I 

118 lENIXDP * ; 

119 I 

120 length |INT PROC length (TEXT CONST text ) : 

121 I EXTERNAL 53 

122 lENDPROC length ; 

123 I 

124 LENGTH | INT OP LENGTH (TEXT CONST text ) : 

125 I EXTERNAL 53 

126 lENIXDP LENGTH ; 

127 I 

128 pos I INT PROC pos (TEXT CONST source, pattern) : 

129 I EXTERNAL 54 

130 lENDPROC pos ; 

131 I 

132 pos I INT PROC pos (TEXT CONST source, pattern, INT CONST from) : 

133 I EXTERNAL 55 

134 lENDPROC pos ; 

135 I 

136 pos I INT PR(DC pos (TEXT CONST source, pattern, INT CONST from, to) : 

137 I EXTERNAL 56 

138 lENDPROC pos ; 

139 I 

140 pos I INT PROC pos (TEXT CONST source, low, high, INT CONST from) : 

141 I EXTERNAL 58 

142 lENDPROC pos ; 

143 I 
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144 compress |TEXT PROC compress fTEXT CCNST text; : 

145 I 

146 I INT VAR begin, end ; 

147 I 

148 I search first non blank ; 

149 I search last non blank ; 

150 I text buffer := subtext ftext, begin, end) ; 

151 I text buffer . 

152 I 

153 searchfirstnonblank [search first non blank : 

154 1 begin :» 1 ; 

15.!- I A'HILE (text SUB begin) . " " REP 

156 I begin INCR 1 

157 I PER . 

158 I 

159 searchlastnonblank j search last non blank : 

160 I end := LENGTH text ; 

161 I WHILE (text SUB end) . " " REP 

162 I end DECR 1 

163 I PER . 

164 I 

165 lENIPROC compress ; 

166 I 

167 change |PROC change (TEXT VAR destination, INT CONST from, to, TEXT CXMJST 

I new) : 

168 I 

169 I ir LENGTH new = to - from * 1 AND to <« LENGTH destination 

170 I THEN replace (destination, from, new) 

171 I ELSE change via buffer 

172 I ri . 

173 I 

174 changeviabuffer [change via buffer : 

175 I text buffer :- subtext (destination, 1, from-l) ; 

176 I text buffer CAT new ; 

177 I tail buffer :» subtext (destination, to + 1) ; 

178 I text buffer CAT tail buffer ; 

179 I destination :» text buffer 

180 I 

181 lENDPROC change ; 

182 I 

183 change I PROC change (TEXT VAR destination, TEXT CONST old, new) : 

184 I 

185 I INT CONST position := pos (destination, old) ; 

186 I ir position > 0 

187 I THEN change (destination, position, position + LENGTH old -1, 
f I new) 

188 I FI 

189 I 

190 lENDPROC change ; 

191 I 

192 changeall IPIIOC change all (TEXT VAR destination, TEXT CONST old, new) : 

193 I 

194 I INT VAR position := pos (destination, old) ; 
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195 I ir LENGTH old - LENGTH new 

196 I THDJ change by replace 

197 I ELSE change by change 

198 in. 

199 I 

20© changebyreplace | change by replace : 

201 I WHILE position > 0 REP 

202 I replace (destination, position, new J ; 

203 I position :» pos (destination, old, position ^ LENGTH new) 

204 I PER . 

205 I 

206 changebychange | change by change : 

207 I WHILE position > © REP 

206 I change (destination, position, position * LENGTH old - 1 , new) 

209 I position :« pos (destination, old, position + LENGTH new) 

210 I PER . 

211 I 

212 lENBPROC change all ; 

213 I 

214 deletechar |PROC delete char (TEXT VAR string, INT CONST delete pos) : 

215 I 

216 I IP delete pos > 0 

217 I THEN tall buffer :» subtext (string, delete pos + 1) ; 

218 I string :« subtext (string, 1, delete pos - 1) ; 

219 I string CAT tail buffer 

220 I ri 

221 I 

222 I END PROC delete char ; 

223 I 

224 insertchar |PROC Insert char (TEXT VAR string, TEXT CONST char, 

225 I INT CONST insert pos) : 

226 i 

227 I IP insert pos > 9 AND insert pos <- LENGTH string * 1 

228 I THEN tall buffer := subtext (string. Insert pos) ; 

229 I string :« subtext (string, 1, Insert pos - 1) ; 

230 I string CAT char ; 

231 I string CAT tail buffer 

232 I PI 

233 I 

234 I END PROC insert char ; 

235 I 

236 heaps ize | INT PROC heap size : 

237 I EXTERNAL 93 

238 lENDPROC heap size ; 

239 I 

240 collectheapgarbage |PROC collect heap garbage : 

241 j EXTERNAL 94 

242 [ENDPROC collect heap garbage ; 

243 I 
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244 stranalyze |PROC stranalyze (ROW 256 INT CONST table, INT VAR sum, INT CXINST 

+ I sum, 

245 I TEXT CONST string, INT VAR index, INT CONST to, 

246 I INT VAR exit code) : 

247 I EXTERNAL 57 

248 lENLPROC stranalyze ; 

249 I 

251 |(» lexikographische Vergleiche 

252 |(» Nach DIN 5007, Abschnitt 1 und Abschnitt 3.2 (Bindestrich) 

253 |(* Autor: Rainer Hahn, Jochen Liedtke 

254 |(» Stand: 1.7.4 (Jan. 1985) 

256 I LET first umlaut - ""214'"' , 

257 I umlauts = ""214'"'215*'*'216""217""218""219""251''" ; 

258 I 

259 I 

260 I TEXT VAR left letter, right letter; 

261 I 

262 LEXEQUAL |BOOL OP LEXEQUAL (TEXT CONST left, right) : 

263 I 

264 I compare (left, right) ; 

265 I left letter = right letter 

266 I 

267 lENDOP LEXEQUAL ; 

268 I 

269 LEXGREATER |BOOL OP LEXGREATER (TEXT CONST left, right) : 

270 I 

271 I compare (left, right) ; 

272 I left letter > right letter 

273 I 

274 lENDOP LEXGREATER ; 

275 I 

276 LEXGREATERBQUAL |BOOL OP LEXGREATEREQUAL (TEXT CONST left, right) : 

277 I 

278 I compare Qeft, right) ; 

279 I left letter >« right letter 

280 I 

281 lENLOP LEXGREATEREQUAL ; 

282 I 

283 compare |PROC compare (TEXT CONST left, right) : 

284 I 

285 I to begin of lex relevant text ; 

286 i REP 

287 I get left letter ; 

288 I get right letter 

289 I UNTIL NOT letter match OR both ended PER . 

290 I 



291 tobeginoflexrelevantte 

292 

293 

294 

295 



to begin of lex relevant text : 
INT VAR 

left pos := pos (left, '*"65***',""254"", 1) . 
right pos := pos ( right, **"65*'",-**254"", 1) ; 
IP left pos » 0 
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296 1 THEN left pos LENGTH left ^ 1 

297 i n : 

298 I IF right pos = © 

299 I THEN right pos :- LENGTH right + 1 

30® in. 

301 I 

302 getleftletter |get left letter : 

303 I left letter := left SUB left pos ; 

304 I left pos INCH 1 . 

305 I 

306 getrlghtletter |get right letter : 

307 I right letter :» right SUB right pos ; 

308 I right pos INCH 1 . 

309 I 

31© lettermatch | letter match : 

311 I IT left letter = right letter 

312 I THEN TRUE 

313 I ELSE dine (left, left letter, left pos) ; 

314 I dine (right, right letter, right pos) ; 

315 I IP exactly one letter is double letter 

316 j THEN expand other letter 

317 I ri ; 

318 I left letter = right letter 

319 I FX . 
32© I 

321 exactlyone letter! sdoub | exactly one letter is double letter : 

322 I LENGTH left letter <> LENGTH right letter. 

323 I 

324 expandother letter [expand other letter : 

325 i IF LENGTH left letter = 1 

326 I THEN left letter CAT (left SUB left pos) ; 

327 I left pos INCH 1 

328 I ELSE right letter CAT (right SUB right pos) ; 

329 I right pos INCH 1 

330 in. 

331 I 

332 bothended iboth ended : left letter = . 

333 I 

334 isNDPROC compare ; 

335 I 

336 dine IPROC dine (TEXT CONST string, TEXT VAR char, INT VAR string pos) 

337 i 

338 I skip non letter chars ; 

339 i IF is capital letter 

340 I THEN translate to small letter 

341 j ELIF char >= first umlaut 

342 I THEN translate umlaut 

343 in. 

344 I 

345 skipnonletterchars I skip non letter chars : 

346 i WHILE NOT (is letter OR end of string) REP 

347 I char := string SUB string pos ; 

348 i string pos INCR 1 
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349 I PER . 

350 I 

351 translatetosrAllletter [translate to small letter : 

352 I char :» code (code (char) +32) . 

353 I 

354 trans la teumlaut [translate umlaut : 

355 I SELECT pos (umlauts, char) OP 

356 I CASE 1,4 : char := "ae** 

357 I CASE 2,5 : char := ''oe'' 

358 I CASE 3,6 : char := "ue'' 

359 I CASE 7 : char := "ss** 

360 I ENDSELECT . 

361 1 

362 iscapitalletter |is capital letter : 

363 I INT VAR char code :« code (char) ; 

364 I 65 <= char code AND char code <= 90 . 

365 I 

366 Isletter jis letter ; 

367 I char code ;« code (char) OR 32 ; 

368 I (97 <= char code Al^D char code <» 122) OR chax code >= 128 . 

369 I 

370 endof string |end of string : chaur « . 

371 I 

372 lENDPROC dine ; 

373 I 

374 CAT I OP CAT (TEXT VAR result, INT CONST number) : 

375 I result CAT " 

376 I replace (result, LENGTH result DIV 2, number); 

377 I END OP CAT; 

378 I 

379 insertint |PROC insert int (TEXT VAR result, INT CONST insert pos, number) 

380 j INT VAR pos := insert pos » 2 - 1; 

381 I change (result, pos, pos - 1, **); 

382 I replace (result, insert pos, number); 

383 I END PROC insert int; 

384 I 

385 deleteint |PROC delete int (TEXT VAR result, INT CONST delete pos) : 

386 I INT VAR pos := delete pos ♦ 2; 

387 I change (result, pos - 1, pos, ***•) 

388 lEND PROC delete int; 

389 I 

390 lENDPACKET text ; 
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1 I 

2 pcbandinitcontrol •»<mhmhh» j PACKET pcb and init control DEFINES (» Autor: J.Liedtke •) 

3 I (• SUnd: 25.08.84 •) 

4 I session , 

5 I pcb , 

6 I sot lino nr , 

7 I clock , 

8 I INITFLAG , 

9 I . 

10 I Initializod , 

11 I storage , 

12 I id , 

13 I ke : 

14 I 

15 I 

16 I LET line number field = 1 , 

17 I myself id field « 9 ; 

18 I 

19 ITYPE INITFLAG . INT ; 

20 I 

21 j 

22 session | INT PROC session : 

23 I EXTERNAL 126 

24 lENDPROC session ; 

25 I 

26 pcb I INT PROC pcb (INT CONST field) : 

27 I EXTERNAL 80 

28 lENDPROC pcb ; 

29 I 

30 writopcb |PROC write pcb (INT CONST task nr, field, value) : 

31 I EXTERNAL 105 

32 lENDPROC write pcb ; 

33 I 

34 setlinenr | PROC set line nr ( INT CONST value ) : 

35 I write pcb (pcb (myself id field), line number field, value) 

36 |ENDPR(X: set line nr ; 

37 I 

38 I 

39 :» |0P (INITFLAG VAR flag, BOOL CONST flagtrue) : 

40 I 

41 I IF flagtrue 

42 I THEN CONCR (flag) myself no 

43 I ELSE CONCR (flag) 0 

44 I FI . 

45 I 

46 myself no {myself no : pcb (myself id field) AND 255 . 

47 I 

48 lENDOP :x ; 

49 I 
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50 initialized |BOOL PROC initialized (INITFLAG VAR flag) : 

51 I 

52 I IF CONCR (flag) = myself no 

53 I THEN TRUE 

54 I ELSE CONCR (flag) := myself no ; 

55 I FALSE 

56 I FI . 

57 I 

I 

58 myself no | myself no : pcb (myself id field) AND 255 

59 I 

60 lENDPROC initialized ; 

61 I 



62 clock I REAL PROC clock (INT CONST nr) : 

63 I EXTERNAL 102 

64 lENDPROC clock ; 

65 I 



66 storage |PROC storage (INT VAR size, used) 

67 I EXTERNAL 89 

68 lENDPROC storage ; 

69 I 



70 id I INT PROC id (INT CONST no) : 

71 I EXTERNAL 129 

72 lENDPROC id ; 

73 I 



74 ke IPROC ke : 

75 I EXTERNAL 6 

76 lENDPROC ke ; 

77 I 

78 lENDPACKET pcb and init control ; 
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1 |(» VERSION 3 22.04.86 

2 dataspace | PACKET dataspace DEFINES 

3 I 

4 I := , 

5 I nilspace , 

6 I forget , 

7 I type , 

8 I heap size , 

9 j storage , 

10 I ds pages , 

11 I next ds page » 

12 I blockout , 

13 I blockin , 

14 I ALIGN : 

15 I 

16 I 

17 I LET myself id field = 9 , 

18 1 lowest ds number = 4 , 

19 j highest ds number = 255 ; 

20 I 

21 ITYPE ALIGN = ROW 252 INT ; 

22 I 

23 := I OP := (DATASPACE VAR dest, DATASPACE CONST source ) : 

24 I EXTERNAL 70 

25 lENDOP := ; 

26 I 

27 nilspace | DATASPACE PROC nilspace : 

28 I EXTERNAL 69 

29 lENDPROC nilspace ; 

30 I 

31 forget I PROC forget (DATASPACE CONST dataspace ) : 

32 I EXTERNAL 71 

33 lENDPROC forget ; 

34 I 

35 type |PROC type (DATASPACE CONST ds, INT CONST type) : 

36 I EXTERNAL 72 

37 lENDPROC type ; 

38 I 

39 type |INT PROC type (DATASPACE CONST ds) : 

40 I EXTERNAL 73 

41 lENDPROC type ; 

42 I 

43 heapslze |INT PROC heap size (DATASPACE CONST ds) : 

44 i EXTERNAL 74 

45 lENDPROC heap size ; 

46 I 
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47 storage |INT PROC storage (DATASPACE CONST ds) : 

48 I (ds pages (ds) * 1) DIV 2 

49 lENDPROC storage ; 

se I 

51 dspages |INT PROC ds pages (DATASPACE CONST ds) : 

52 I pages (ds, pcb (myself Id field)) 

53 lENDPROC ds pages ; 

54 I 

55 pages |INT PROC pages (DATASPACE CONST ds, INT CONST task nr) : 

56 I EXTERNAL 88 

57 lENDPROC pages ; 

58 I 

59 nextdspage |INT PROC next ds page (DATASPACE CONST ds, INT CONST page nr) : 

60 I EXTERNAL 87 

61 lENDPROC next ds page ; 

62 I 

63 blockout I PROC blockout (DATASPACE CONST ds, INT CONST page nr, codel, code2, 

64 I INT VAR return code) : 

65 I EXTERNAL 85 

66 lENDPROC blockout ; 

67 I 

68 blockin |PROC blockln (DATASPACE VAR ds, INT CONST page nr, codel, code2, 

69 I INT VAR return code) : 

70 I EXTERNAL 86 

71 lENDPROC blockin ; 

72 I 

73 lENDPACKET dataspace ; 
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1 I 

2 basictpansput « >| PACKET basic transput DEFINES 

3 I out , 

4 I out subtext , 

5 I outtext , 

6 I TIMESOUT , 

7 I cout » 

8 I display , 

9 I inchar , 

10 I incharety , 

11 I cat input , 

12 j pause , 

13 I cursor , 

14 I get cursor , 

15 I channel , 

16 I online , 

17 I control , 

18 I blockout , 

19 I blockln : 

20 I 

21 I 

22 1 

23 I LET channel field > 4 , 

24 I blank times 64 > 

25 I 

I " ; 

26 I 

27 I LET BLOCKIO = STRUCT (ALIGN page align, ROW 256 INT buffer) , 

28 I buffer page « 2 ; 

29 I 

30 I BOUND BLOCKIO VAR block io ; 

31 IDATASPACE VAR block io ds ; 

32 jlNITFLAG VAR this packet FALSE ; 

33 I 

34 1 

35 out IPROC out (TEXT CONST text ) : 

36 1 EXTERNAL 60 

37 jiWDPROC out ; 

38 I 

39 outsubtext |PROC outsubtext ( TEXT CONST source, INT CONST from ) : 

40 I EXTERNAL 62 

41 lEND PROC outsubtext; 

42 I 

43 outsubtext |PROC outsubtext (TEXT CONST source, INT CONST from, to) : 

44 I EXTERNAL 63 

45 I END PROC outsubtext; 

46 I 

47 outtext IPROC outtext ( TEXT CONST source, INT CONST from, to ) : 

48 I out subtext (source, from, to) ; 

49 I INT VAR trailing ; 

50 I IF from <= LENGTH source 

51 I THEN trailing :» to - LENGTH source 

52 I ELSE trailing :- to + 1 - from 

53 I FI ; 
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54 I IF trailing > 0 

55 I THEN trailing TIMESOUT " " 

56 I n 

57 lENDPROC outtext ; 

58 I 

59 TIMESOUT |0P TIMESOUT (INT CONST times, TEXT CX)NST text) : 

60 I 

61 I IF text = " " 

62 j THEN fast timesout blank 

63 I ELSE timesout 

64 I FI . 

65 I 

66 fasttimesoutblank jfast timesout blank : 

67 j INT VAR i := 0 ; 

68 I WHILE i + 64 < times REP 

69 1 out (blank times 64) ; 

70 I i INCH 64 

71 I PER ; 

72 I outsubtext (blank times 64, 1, times - i) . 

73 I 

74 timesout j timesout : 

75 I FOR i FROM 1 UPTO times REP 

76 1 out (text) 

77 I ENDREP . 

78 I 

79 lENDOP TIMESOUT ; 

80 I 

81 display |PROC display (TEXT CONST text) : 

82 I IF online 

83 I THEN out (text) 

84 I FI 

85 lENDPROC display ; 

86 I 

87 inchar |PROC inchar (TEXT VAR character ) : 

88 I EXTERNAL 64 

89 |ENi3?R0C inchar ; 

90 I 

91 incharety | TEXT PROC incharety : 

92 I EXTERNAL 65 

93 lEND PROC incharety ; 

94 I 

95 incharety |TEXT PROC incharety (INT CONST time limit) : 

96 I internal pause (time limit) ; 

97 I incharety 

98 lENDPROC incharety ; 

99 I 
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100 paus© IPROC pause (INT CONST time limit) : 

101 I internal pause (time limit) ; 

102 I TEXT CONST dummy := incharety 

103 lENDPROC pause ; 

104 I 

105 pause | PROC pause : 

106 I TEXT VAR dummy; inchar (dummy) 

107 lENDPROC pause ; 

108 I 

109 internalpause |PROC internal pause (INT CONST time limit) : 

110 I EXTERNAL 66 

111 lENDPROC internal pause ; 

112 I 

113 catinput |PROC cat input (TEXT VAR t, esc char) : 

114 I EXTERNAL 68 

115 lENDPROC cat input ; 

116 I 

117 I 

118 cursor |PROC cursor (INT CONST x, y) : 

119 I out (""6"") ; 

120 I out (code(y-l)) ; 

121 I out (code(x-l)) ; 

122 lENDPROC cursor ; 

123 I 

124 getcursor |PROC get cursor (INT VAR x, y) : 

125 I EXTERNAL 67 

126 lENDPROC get cursor ; 

127 I 

128 cout I PROC cout (INT CONST number) : 

129 I EXTERNAL 61 

130 lENDPROC cout ; 

131 I 

132 I 

133 channel | INT PROC channel : 

134 I pcb (channel field) 

135 lENDPROC channel ; 

136 I 

137 online |BOOL PROC online : 

138 I pcb (channel field) <> 0 

139 jiUDPROC online ; 

140 i 

141 I 
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142 control |PROC control (IKT OONST codel, codeS, codeS, INT VAR return coda) 

143 I EmRNAL 64 

144 joiBFROC control ; 

145 I 

146 blockout IFROC blockout (ROW 256 INT OGHST block, INT OONST codel, code2, 

147 I INT ?AR return code) : 

148 I 

149 I access block io ds ; 

156 i block io. buffer :> block ; 

151 I blockout (block io ds, buffer page, codel, code2, return code) 

152 I 

153 accessblockiods | access block io ds : 

154 j IF NOT initialized (this packet) 

155 I THEN block io ds nilspace 

156 in; 

157 I block io :< block io ds . 

158 I 

159 lENBFROC blockout ; 
166 I 

161 blockin |FROC blockin (ROW 256 INT VAR block, INT OONST codel, code2, 

162 I INT VAR return code) : 

163 I 

164 I access block io ds ; 

165 I blockin (block io ds, buffer page, codel, code2, return code) ; 

166 I block block io. buffer . 

167 I 

168 accessblockiods j access block io ds : , 

169 i IF NOT initialized (this packet) 
176 I THEN block io ds nilspace 

171 I FI ; 

172 I block io block io ds . 

173 I 

174 lENBFROC blockin ; 

175 I 

176 joiDPACKET basic transput ; 

177 I 
178 
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1 I 

2 bool I PACKET bool BEFINES XOR, true, falsa 

3 I 

4 (BOOL CONST true TRUE , 

5 I false:. FALSE ; 

6 I 

7 XOR IBOOL OP XOR (BOOL CONST left, right) : 

e I 

9 I IT left THEN NOT right 

le I ELSE right 

11 I FX 

12 I 

13 laiSOP XOR ; 

14 I 

15 IENHPACKET bool ; 
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1 |(» STAND : 23.10.85 

I *) 

2 integer j PACKET integer DEFINES text, int, MOD» 

3 I sign, SIGN, abs, ABS, **, min, max, nlnint, 
•t- I maxint, 

4 I random, initialize random , 

5 I last conversion ok, set conversion : 

6 1 

7 rainint | INT PROC minint : -32767 - 1 ENDPROC rainint ; 

8 I 

9 maxint | INT PROC maxint : 32767 ENDPROC maxint ; 

10 I 

11 I 

12 text I TEXT PROC text (INT CONST number) : 

13 I 

14 I IF number = minint THEN "-32768" 

15 I ELIF number < 0 THEN + text( -number) 

16 I ELIF number <= 9 THEN code (number + 48) 

17 I ELSE text (number DIV 10) + digit 

18 I FI . 

19 I 

20 digit I digit : 

21 I code ( number MOD 10 48 ) . 

22 I 

I ENDPROC text ; 

24 I 

25 text I TEXT PROC text (INT CONST number, length) : 

26 I 

27 I TEXT VAR result := text (number) ; 

28 I INT CONST number length :> IiE3<lGTH result ; 

29 I IF number length < length 

30 I THEN (length - number length) « " " + result 

31 I ELIF number length > length 

32 I THEN length * 

33 I ELSE result 

34 I FI 

35 I 

36 I ENDPROC text ; 

37 1 

38 int I INT PROC int (TEXT CONST number) : 

39 I 

46 I skip blanks and sign ; 

41 I get value ; 

42 I result . 

43 I 

44 sklpblanksandsign I skip blanks and sign : 

45 I BOOL VAR number is positive ; 

46 I INT VAR pos := 1 ; 

47 I skip blanks ; 

48 I IF (number SUB pos) « "-** 
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49 I THEN number is positive := FALSE ; 

50 I pos INCR 1 

51 I ELIF (number SUB pos) = 

52 I THEN number is positive := TRUE ; 

53 I pos INCR 1 

54 I ELSE number is positive := TRUE 

55 I FI . 

56 I 

57 getvalue |get value : 

58 I INT VAR value ; 

59 I get first digit ; 

60 1 WHILE is digit REP 

61 I value := value ♦ 10 + digit ; 

62 1 pos INCR 1 

63 I PER ; 

64 1 set conversion ok result . 

65 I 

66 getfirstdigit |get first digit ; 

67 1 IF is digit 

68 I THEN value := digit ; 

69 I pos INCR 1 

70 I ELSE set conversion (FALSE) ; 

71 I LEAVE int WITH 0 

72 I FI . 

73 I 

74 isdigit lis digit ; 0 <« digit AND digit <« 9 . 

75 I 

76 digit [digit : code (number SUB pos) - 48 . 

77 I 

78 result | result : 

79 I IF number is positive 

80 I THEN value 

81 I ELSE - value 

82 I FI . 

83 I 

84 setconversionokresult jset conversion ok result : 

85 I skip blanks ; 

86 I conversion ok :> (pos > LENGTH number) . 

87 I 

88 skipblanks I skip blanks : 

89 I WHILE (number SUB pos) - " " REP 

90 I pos INCR 1 

91 I PER . 

92 I 

93 lENDPROC int ; 

94 I 

95 MOD I INT OP MOD (INT CONST left, right) : 

96 I 

97 I EXTERNAL 43 

98 j 

99 lENDOP MOD ; 
100 I 
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lei sign jlNT PROC sign (IHT OQKST axgu»ent) : 

102 I 

163 I IT arguaent < 6 THEM -1 

164 I ELIF arguaent > 6 THBi 1 

165 1 ELSE 6 

166 I n 

107 I 

168 iBIDFflOC sign ; 

199 1 

116 SIGN I INT OP SIGN (INT CONST argiMent) : 

111 I sign (arguaent) 

112 l EKDOP SIGN ; 

113 I 

114 abs I INT PROC abs (INT CONST argument) : 

115 I 

116 1 IP argunent > 6 THEN arguoent 

117 I ELSE - argument 

118 I PI 

119 I 

126 jaiBFROC abs ; 

121 I 

122 ABS |INT OP ABS (INT CONST argument) : 

123 I abs (argument) 

124 lENDOP ABS ; 

125 I 

126 «M» |INT OP (INT CONST arg, exp) : 

127 I 

128 I INT VAR X := arg , z := 1 . 

129 I counter :« exp ; 
136 I 

131 I IF exp - e 

132 I THEN LEAVE WITH 1 

133 I ELIF exp < 0 

134 I THIN LEAVE WITH 1 DIV arg 

135 I FI ; 

136 I 

137 I WHILE counter >. 2 REP 

138 I calculate new x and z ; 

139 I counter := counter DIV 2 ; 
146 I Onx^ ; 

141 I z • X . 

142 I 

143 calculatenewxandz | calculate new x and z : 

144 I IF counter is not even 

145 I THEN z z ♦ X 

146 I FI ; 

147 I X :« X • X . 

148 I 

149 counterlsnoteven | counter is not even : 
156 I counter MOD 2 - 1 . 

151 I 

152 lENDOP ; 
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153 I 

154 Bin IINT FROC Bin (INT CONST first, second) : 

155 I 

156 I IP first < second THSi first ELSE second FI 

157 I 

156 IBUIHUC Bin ; 

159 I 

168 max |INT FROC aax (INT CONST first, second) : 

161 I 

162 I IF first > second THBH first ELSE second FI 

163 I 

164 lENUFROC max ; 

165 I 

166 I 

167 I 

168 I BOOL VAR comrersion ok :> TRUE ; 

169 I 

179 lastconversionok |BOOL PROC last conversion ok : 

171 I conversion ok 

172 lENDFROC last conversion ok ; 

173 1 

174 setconversion |FROC set conversion (BOOL CX)NST success) : 

175 I conversion ok := success 

176 lENBFROC set conversion ; 

177 I 

178 I 

179 I 

lae |( ; 

181 |(» 

182 i(«» Autor: A. Flannenkanp •] 

183 |(» RANDOM GENERATOR •] 

184 l(» 

185 |(» X :> 4695 • x MOD (4695*4696^4693) 

186 |(» n+1 n •] 

187 !(• •; 

188 |(« Periode: 2«m»24-4 > 16.6e6 •; 

189 |(» 

196 |(« Beachte: x = 4696 ♦ xl + x8. 6 <« x8.xl < 4696 •] 

191 !(• 

192 I ( ] 

193 I 

194 I 

195 I INT VAR high 1, low :» 6 ; 

196 I 

197 initializerandom |PROC initialize random (INT CONST start) : 

198 I 

199 I low :- start MOD 4696 ; 
286 I IF start < 6 

261 I THEN high := 256 + 16 + start DIV 4696 ; 

262 I IF low <> 6 THEN high DECR 1 FI 

263 I ELSE high :- 256 -»- start DIV 4696 

264 I FI 
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205 I 

296 lENDPROC Initialize random ; 

207 I 

208 random I INT PROC random (INT CONST lower bound, upper bound) : 

209 I 

210 I compute new random value ; 

211 I normalize high ; 

212 I normalize low ; 

213 I map into interval . 

214 I 

215 computenewrandomvalue | compute new random value : 

216 I (• (high, low) (low-high , 3*»high-low) •) 

217 I high := low - high ; 

218 I low INCR low - 3 » high 

219 I 

220 normalizehigh | normalize high : 

221 I IF high < 0 

222 1 THEN high INCR 4096 ; low DECR 3 

223 I FI . 

224 1 

225 normalizelow jnormalize low : 

226 I (» high INCR low DIV 4096 ; 

227 1 low := low MOD 4096 

228 I •) 

229 I IF low >= 4096 THEN low overflow 

230 I ELIF low < 0 THEN low underflow 

231 1 FI . 

232 I 

233 lowoverflow jlow overflow : 

234 I IF low >= 8192 

235 i THEN low DECR 8192 ; high INCR 2 

236 I ELSE low DECR 4096 ; high INCR 1 ; post normalization 

237 I ri • 

238 I 

239 postnormalization jpost normalization : 

240 I (• IF (high, low) >« (4095.4093) 

241 I THEN (high, low) DECR (4095,4093) 

242 I FI 

243 I •) 

244 I IF high >« 4095 

245 I THEN IF low >« 4093 THEN high DECR 4095 ; low DECR 4893 

246 I ELIF high = 4896 THiW high := 8 ; low INCR 3 

247 1 FI 

248 I FI . 

249 I 

250 lowunderflow jlow underflow : 

251 1 low INCR 4896 ; high DECR 1 . 

252 I 

253 napintolnterval |map into Interval : 

254 I INT VAR number :- high MOD 16 - 8 ; 

255 1 number INCR 4895 • number low ; 

256 I IF lower bound <- upper bound 

297 I THEM lower bound ^ number NOD (upper bound - lower bound * 1) 
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258 I ELSE upper bound + number MOD (lower bound - upper bound + 1) 

259 I ri . 

260 I 

261 lENDPROC random ; 

262 I 

263 I 

264 lENDPACKET integer ; 
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errorhandling 



enablestop 



disablestop 



seterrorstop 



clear error 



se lec terrorme s sage 



PACKET error handling DEFINES 

enable stop , 
disable stop , 
is error , 
clear error , 
errormessage , 
error code , 
error line , 
put error , 
errors top , 
stop : 



LET cr If = *"*13''"10" 

line nr field = 1 , 
error line field = 2 , 
error code field = 3 , 
syntax error code= 100 , 



"7***'13*'"10"*'5*'FEHLER 



error pre 



TEXT VAR errortext := 



PROC enable stop : 

EXTERNAL 75 
ENDPROC enable stop ; 



PROC disable stop : 

EXTERNAL 76 
ENDPROC disable stop ; 



PROC set error stop (INT CONST code) 

EXTERNAL 77 
ENDPROC set error stop ; 



BOOL PROC is error : 

EXTERNAL 78 
ENDPROC is error ; 



PROC clear error : 

EXTERNAL 79 
ENDPROC clear error ; 



PROC select error message 
SELECT error code OF 
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51 


1 CASE 


1 : 


error 


text 




*'*halt' vom Terminal** 


52 


1 CASE 


2 : 


error 


text 




"Stack-Ueberlauf** 


53 


1 CASE 


3 : 


error 


text 




Heap-UeDeriaur 


54 


1 CASE 


4 : 


error 


text 


• - 


INT-UeDerlaur 


55 


1 CASE 


5 : 


error 


text 


' - 


**DIV durch 0** 


56 


1 CASE 


6 : 


error 


text 


• * 


REAL-UeDeriaur 


57 


1 CASE 


7 : 


error 


text 




TEXT-Ueberlauf 


58 


1 CASE 


o . 


error 


xexx 




"tii vioIa TlATAQ'PAPTI'c** 


59 


1 CASE 


9 : 


error 


text 




**Ueberlauf bei Subskription** 
*'Unterlauf bei Subskription** 


60 


CASE 


10: 




text 




61 


1 CASE 


11: 


error 


text 




**falscher DATASPACE-Zugriff** 


62 


1 CASE 


12: 


error 


text 




**INT nicht initialisiert** 


63 


1 CASE 


13: 


error 


text 




"REAL nicht initialisiert** 


64 


1 CASE 


14: 


error 


text 




*'TEXT nicht initialisiert** 


65 


1 CASE 


15: 


error 


text 




**nicht implementiert** 


66 


1 CASE 


16: 


error 


text 




*'Block unlesbar** 


67 


1 CASE 


17: 


error 


text 




"Codefehler" 



68 I END SELECT 

69 1 

70 lENLPROC select error message ; 

71 I 

72 errormessage [TEXT PROC error message : 

73 I 

74 I select error message ; 

75 I error text 

76 I 

77 lENLPROC error message ; 

78 I 

79 errorcode | INT PROC error code : 

80 I 

81 I pcb (error code field) 

82 I 

83 lENDPROC error code ; 

84 I 

85 error line | INT PROC error line : 

86 I 

87 I IF is error 

88 I THEN pcb (error line field) 

89 I ELSE 0 
9© I FI 

91 I 

92 lENDPROC error line ; 

93 I 

94 syntaxerror |PROC syntax error (TEXT CONST message) : 

95 I 

96 I INTERNAL 259 ; 

97 I errorstop (syntax error code, message) . 

98 I 

99 lENDPROC syntax error ; 
100 I 
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101 errorstop |PROC errorstop (TEXT CONST message) : 

102 I 

103 I errorstop (0, message) ; 

104 I 

105 lENDPROC errorstop ; 

106 I 

107 errorstop |PROC errorstop (INT CONST code, TEXT CONST message) : 

108 I 

109 I IF NOT is error 

110 I THEN error text :* message ; 

111 I set error stop (code) 

112 I FI 

113 I 

114 lENDPROC errorstop ; 

115 I 

116 puterror | PROG put error : 

117 I 

118 I IF is error 

119 I THEN select error message ; 

120 I IF error text <> 

121 I THEN put error message 

122 I FI 

123 I FI . 

124 I 

125 puterrormessage jput error message : 

126 I out (error pre) ; 

127 I out (error text) ; 

128 I IF error line > 0 

129 I THEN out (** bei Zeile **); out (text (error line)) ; 

130 I FI ; 

131 I out (cr If) . 

132 I 

133 lENDPROC put error ; 

134 I 

135 stop I PROC stop : 

136 I 

137 I errorstop ("stop") 

138 I 

139 lENDPROC stop ; 

140 I 

141 lENDPACKET error handling ; 



9/3 



error handling 



9/3 



Zeile ELAN EUMEL 1.8 10.11.86 »»•• real 

1 !(• VERSION 6 05.05.86 • 

2 real <hhhh»»w wwmw j PACKET real DEFINES {♦ Autor: J.Liedtke • 

3 I 

4 I text , 

5 I int , 

6 I real , 

7 I round , 

8 I floor , 

9 1 frac , 

10 I decimal exponent , 

11 I set exp , 

12 I INCR , 

13 I DECR , 

14 I abs , 

15 I ABS , 

16 I sign , 

17 I SIGN , 

18 i MOD , 

19 I min , 

20 I max , 

21 I max real , 

22 I small real : 

23 I 

24 I LET mantissa length = 13 , 

25 I digit zero index » 1 , 

26 I digit nine index = 10 ; 

27 I INT CONST 

28 I decimal point index :> -1 ; 

29 1 

30 I TEXT VAR mantissa ; 

31 I 

32 I ROW 10 REAL VAR real digit ; 

33 I 

34 I INT VAR i ; REAL VAR d := 0.0 ; 

35 IFOR i FROM 1 UPTO 10 REP 

36 I real digit (i) ;= d ; 

37 I d := d + 1.0 

38 jpER ; 

39 I 

40 maxreal |REAL PROC max real : 9 . 999999999999el26 ENDPROC max real ; 

41 I 

42 smallreal |REAL PROC small real : 1.0e-12 ENDPROC small real ; 

43 I 

44 sld IPROC sld (INT CONST in, REAL VAR real, INT VAR out) : 

45 I EXTERNAL 96 

46 I ENDPROC sld ; 

47 I 

48 decimalexponent |INT PROC decimal exponent (REAL CONST mantissa) : 

49 i EXTERNAL 97 

50 [ENDPROC decimal exponent ; 

51 I 
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52 setexp |PROC set exp (INT CONST exponent, REAL VAR number) : 

53 I EXTERNAL 98 

54 lENDPROC set exp ; 

55 I 

56 tenpower |REAL PROC tenpower (INT (X)NST exponent) : 

57 I REAL VAR result := 1.0 ; 

58 I set exp (exponent, result) ; 

59 I result 

60 lENDPROC tenpower ; 

61 I 

62 floor I REAL PROC floor (REAL CONST real) : 

63 I EXTERNAL 99 

64 lENDPROC floor ; 

65 I 

66 round |REAL PROC round (REAL CONST real, INT CONST digits) : 

67 I 

68 I REAL VAR result := real ; 

69 I IF (real <> 0.0) CAND (decimal exponent (real) + digits < mantissa 
+ I length) 

70 I THEN round result ; 

71 I FI ; 

72 I result . 

73 I 

74 roundresult | round result : 

75 I set exp (decimal exponent (result) + digits, result) ; 

76 I IF result >= 0.0 

77 I THEN result := floor (result +0.5) 

78 I ELSE result floor (result - 0.5) 

79 I FI ; 

80 I IF result <> 0.0 

81 I THEN set exp (decimal exponent (result) - digits, result) 

82 I FI . 

83 I 

84 lENDPROC round ; 

85 I 

86 I TEXT VAR result ; 

87 I 

88 text jTEXT PROC text (REAL CONST real) : 

89 I 

90 I REAL VAR value :« rounded to seven digits ; 

91 I IF value - 0.0 

92 I THEN "0.0*' 

93 I ELSE 

94 I process sign ; 

95 j get mantissa (value) ; 

96 I INT CONST exponent := decimal exponent (value) ; 

97 I get short mantissa ; 

98 I IF exponent > 7 OR exponent < LENGTH short mantissa - 7 

99 I THEN scientific notation 

100 I ELSE short notation 

101 I FI 

102 I FI . 
163 I 
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104 roundedtosevendigits | rounded to seven digits : 

105 I round ( real » tenpower( -decimal exponent (real) ) , 6 ) 

106 I • tenpower ( decimal exponent (real) ) . 

107 I 

108 processsign [process sign : 

109 I IF value < 0.0 

110 I THEN result 

111 I value := - value 

112 I ELSE result := **** 

113 I FI . 

114 I 

115 getshortmantissa jget short mantissa : 

116 I INT VAR i : = 7 ; 

117 I WHILE (mantissa SUB i) - '*0" REP 

118 ! i DECR 1 

119 I UNTIL i=l END REP ; 

120 I TEXT CONST short mantissa := subtext (mantissa, 1, i) . 

121 I 

122 scientificnotation [scientific notation : 

123 I result CAT (mantissa SUB 1) ; 

124 1 result CAT ; 

125 I result CAT subtext (mantissa, 2, 7) ; 

126 1 result + "e** + text (exponent) . 

127 I 

128 shortnotation | short notation : 

129 I IF exponent < 0 

130 I THEN result + '*0.*' + (-exponent - 1) + short mantissa 

131 I ELSE result CAT subtext (short mantissa, 1, exponent+1) ; 

132 I result CAT (exponent+1 - LENGTH short mantissa) • "0" ; 

133 I result CAT ; 

134 I result CAT subtext (short mantissa, exponent+2) ; 

135 I IF LENGTH short mantissa < exponent + 2 

136 I THEN result + "0" 

137 j ELSE result 

138 I FI 

139 I FI . 

140 I 

141 lENDPRCX: text ; 

142 I 

143 getmantissa |PROC get mantissa (REAL CONST number) : 

144 I 

145 1 REAL VAR real mantissa := number ; 

146 I mantissa := ; 

147 I INT VAR i , digit ; 

148 I FOR i FROM 1 UPTO mantissa length REP 

149 I sld (0, real mantissa, digit) ; 

150 I mantissa CAT code (digit + 48) 

151 I PER ; 

152 I 

153 lENDPROC get mantissa ; 

154 I 

155 text I TEXT PROC text (REAL CONST real, INT CONST length) : 

156 I 

157 I INT CONST mantissa length := min (length - 7, 13) ; 
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158 I IF mantissa length > 0 

159 I THEN construct scientific notation 

160 I ELSE result := length • 

161 I ri ; 

162 I result . 

163 I 

164 constructscientificnot | construct scientific notation : 

165 1 REAL VAR value := rounded real ; 

166 I IF value =0.0 

167 I THEN result := subtext ("0.0 1, length) 

168 I ELSE process sign ; 

169 I process mantissa ; 

170 I process exponent 

171 I n . 

172 I 

173 roundedreal (rounded real : 

174 I round (real • tenpower ( -decimal exponent (real)) , mantissa 
+ I length - 1) 

175 I • tenpower (decimal exponent (real)) . 

176 I 

177 processsign (process sign : 

178 I IF value < 0.0 

179 I THEN result :« 

180 I ELSE result := 

181 I FX . 

182 I 

183 processmantissa (process mantissa : 

184 j get mantissa (value) ; 

185 i result CAT (mantissa SUB 1) ; 

186 i result CAT ; 

187 I result CAT subtext (mantissa, 2, mantissa length) . 

188 ( 

189 processexponent (process exponent : 

190 I IF decimal exponent (value) >= 0 

191 i THEN result CAT '"e^" 

192 i ELSE result CAT "e-" 

193 ( FI ; 

194 j result CAT text (ABS decimal exponent (value), 3) ; 

195 I change all (result, " "0") . 

196 ( 

197 (ENDPROC text ; 

198 ( 

199 text [TEXT PROC text (REAL CONST real, INT CONST length, fracs) : 

200 ( 

201 ( REAL VAR value := round (real, fracs) ; 

202 ( INT VAR exponent := decimal exponent (value) ; 

203 I IF value = 0.0 THEN exponent 0 FI ; 

204 i INT VAR floors :» exponent + 1 , 

205 i floor length :« length - fracs - 1 ; 

206 ( IF value < 0.0 THEN floor length DECR 1 FI ; 

207 i 

208 I IF value too big 

209 i THEN length • 

210 j ELSE transformed value 

211 I FI . 
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212 I 

213 transforraedvalue | transformed value : 

214 I process leading blanks and sign ; 

215 I get mantissa (value) ; 

216 I result CAT subtext (mantissa, 1» floors) ; 

217 I IF LENGTH mantissa < floors 

218 I THEN result CAT (floors - LENGTH mantissa) * "0'* 

219 I FI ; 

220 I result CAT ; 

221 I IF exponent < 0 

222 I THEN result CAT (-floors) • "0" ; 

223 I result CAT subtext (mantissa, 1, length - LENGTH result) 

224 I ELSE result CAT subtext (mantissa, floors+1, floors + fracs) 

225 I FI ; 

226 I IF LENGTH result < length 

227 I THEN result CAT (length - LENGTH result) • "0'* 

228 I FI ; 

229 j result . 

230 I 

231 processleadingblanksan [process leading blanks and sign : 

232 I result := (floor length - max(floors,0) ) • " ; 

233 I IF value < 0.0 

234 I THEN result CAT ; 

235 I value := - value 

236 1 FI . 

237 I 

236 valuetoobig | value too big : 

239 I floors > floor length . 

240 1 

241 lENDPI^ text ; 

242 I 

243 real I REAL PROC real (TEXT CONST text) : 

244 I 

245 I skip leading blanks ; 

246 I sign ; 

247 I mantissa part ; 

248 I exponent ; 

249 I result . 

250 I 

251 skipleadingblanks jskip leading blanks 

252 I INT VAR pos := 1 ; 

253 I skip blanks . 

254 I 

255 skipblanks |skip blanks : 

256 I WHILE (text SUB pos) = " " REP 

257 I pos INCR 1 

258 I PER . 

259 I 

260 sign I sign : 

261 1 BOOL VAR negative ; 

262 I IF (text SUB pos) = 

263 I THEN negative := TRUE ; 

264 I pos INCR 1 

265 I ELIF (text SUB pos) « 
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266 
267 
268 
269 
270 

271 mantlssapart 

272 

273 

274 

275 

276 

277 

278 

279 

280 

281 

282 

283 

284 

285 

286 

287 getfirstdigit 

288 

289 

290 

291 

292 

293 

294 

295 

296 

297 

298 

299 

300 

301 exponent 

302 

303 

304 

305 

306 

307 

308 

309 

310 

311 

312 nomorenonblankcharsper 

313 

314 

315 

316 

317 

316 

319 result 

320 

321 

322 



THEN negative := FALSE ; 
pos INCH 1 
ELSE negative := FALSE 
FI . 



mantissa part: 
REAL VAR value ; 
INT VAR exponent pos := 0 ; 
get first digit ; 
WHILE pos <= LENGTH text REP 

digit := code (text SUB pos) - 47 ; 

IF digit >= digit zero index AND digit <= digit nine index 
THEN value := value • 10.0 + real digit (digit) ; 
pos INCR 1 

ELIF digit = decimal point index AND exponent pos = 0 
THEN pos INCR 1 ; 

exponent pos := pos 
ELSE LEAVE mantissa part 
FI 

END REP . 



get first digit : 

INT VAR digit code (text SUB pos) - 47 ; 
IF digit = decimal point index 
THEN pos INCR 1 ; 

exponent pos := pos ; 

digit := code (text SUB pos) - 47 

FI ; 

IF digit >= digit zero index AND digit <= digit nine index 
THEN value := real digit (digit) ; 

pos INCR 1 
ELSE set conversion (FALSE) ; 

LEAVE real WITH 0.0 

FI . 



exponent : 
INT VAR exp ; 
IF exponent pos > 0 

THEN exp : = exponent pos - pos 

ELSE exp := 0 
FI ; 

IF (text SUB pos) = *'e" 
THEN exp INCR int ( subtext ( text, pos+1) ) 
ELSE no more nonblank chars permitted 

FI . 



no more nonblank chars permitted : 
skip blanks ; 
IF pos > LENGTH text 
THEN set conversion (TRUE) 
ELSE set conversion (FALSE) 
FI . 



result : 

value := value » tenpower (exp) ; 
IF negative 
THEN - value 
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323 I ELSE value 

324 I n . 

325 I 

326 lENDPRCX: real ; 

327 I 

328 j 

329 abs I REAL PRCX: abs (REAL CONST value) : 

33e I 

331 I IF value >= 0.0 

332 I THEN value 

333 I ELSE -value 

334 I n 

335 I 

336 lENDPROC abs ; 

337 I 

338 ABS IREAL OP ABS (REAL CONST value) : 

339 I 

340 I abs (value) 

341 I 

342 |EN])OP ABS ; 

343 I 

344 sign I INT PROC sign (REAL CONST value) : 

345 I 

346 I IF value < 0.0 THEN -1 

347 I ELIF value = 0.0 THEN 0 
346 I ELSE 1 

349 I FI 

350 I 

351 lENDPROC sign ; 

352 I 

353 SIGN I INT OP SIGN (REAL CONST value) : 

354 I 

355 I sign (value) 

356 I 

357 |ENIX)P SIGN ; 

358 I 

359 MOD IREAL OP MOD (REAL CONST left, right) : 

360 I 

361 I REAL VAR result := left - floor (left/right) • right ; 

362 I IF result < 0.0 

363 I THEN result ■»■ abs (right) 

364 I ELSE result 

365 1 FI 

366 i 

367 lENDOP MOD ; 

368 1 

369 frac I REAL PROC frac (REAL CONST value) : 

370 I 

371 I value - floor (value) 

372 I 
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373 lENDPROC frac ; 

374 I 

375 max |REAL PROC max (REAL CONST a, b) : 

376 I 

377 I IF a > b THEN a ELSE b FI 

378 I 

379 lENDPROC max ; 

380 I 

381 min |REAL PROC min (REAL CONST a, b) : 

382 I 

383 I IF a < b THEN a ELSE b FI 

384 I 

385 lENDPROC min ; 

386 I 

387 INCR I OP INCR (REAL VAR dest, REAL CONST increment) : 

388 I 

389 I dest := dest + increment 

390 I 

391 lENDOP INCR ; 

392 I 

393 DECR I OP DECR (REAL VAR dest, REAL CONST decrement) : 

394 I 

395 I dest := dest - decrement 

396 I 

397 lENDOP DECR ; 

398 I 

399 int I INT PROC int (REAL CONST value) : 

400 I 

401 I IF value = minint value 

402 I THEN minint 

403 I ELSE compute int result ; 

404 I IF value < 0.0 

405 j THEN - result 

406 I ELSE result 

407 I FI 

408 I FI . 

409 I 

410 compute intresult | compute int result : 

411 I INT VAR result := 0, digit ,i ; 

412 I REAL VAR mantissa := value ; 

413 I 

414 I FOR i FROM 0 UPTO decimal exponent (value) REP 

415 I sld (0, mantissa, digit) ; 

416 I result := result ♦ 10 + digit 

417 I PER . 

418 I 

419 Dinintvalue j minint value : - 32768.0 . 
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420 minint Iminint : - 32767 - 1 . 

421 I 

422 lENDPROC int ; 

423 I 

424 real |REAL PROC real (INT CONST value) : 

425 I 

426 I IF value < 0 

427 I THEN - real (-value) 

428 I ELIF value < 10 

429 i THEN real digit (value+1) 

430 I ELSE split value into head and last digit ; 

431 I real (head) • 10.0 + real digit (last digit+1) 

432 I FI . 

433 I 

434 splitvalueintoheadandl | split value into head and last digit : 

435 I INT (X)NST 

436 I head := value DIV 10 , 

437 I last digit := value - head » 10 . 

438 I 

439 lENTPROC real ; 

440 I 

441 lENDPACKET real ; 
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1 datehandling •»•«♦»«»»»•»• | PACKET date handling DEFINES date, time, (• Autor: H. 
+ I Indenbirken •) 

2 i time of day, (• Stand: 
i 02.06.1986 (wk)») 

3 I month, day , year , 
i I hour , 

5 I minute, 

6 I second : 

7 1 

8 I LET middle year length = 31557380.0, 

9 I weeklength = 604800.0. 

10 I day length = 86400.0, 

11 I hours = 3600.0, 

12 I minutes = 60.0, 

13 I seconds = 1.0; 

14 I 

15 |(» Tage bis zum Jahr 01.01.1900: 693970.25 5.995903el0 Sekunden 

I *) 

16 |(» Dieser Tag ist ein Montag 

I *) 

17 I 

18 [REAL VAR begin of today := 0.0 , end of today := 0.0 ; 

19 I 

20 I TEXT VAR today , result ; 

21 I 

22 I 

23 I ROW 12 REAL CONST previous days :: ROW 12 REAL : (0.0 , 2678400.0, 
+ I 5097600.0, 

24 I 7776000.0, 10368000.0, 
+ I 13046400.0, 

25 I 15638400.0, 18316800.0, 
+ I 20995200.0, 

26 I 23587200.0 , 26265600.0, 
+ I 28857600.0); 

27 j 

28 day |REAL PROG day: day length END PROG day; 

29 hour I REAL PROG hour: hours END PROC hour; 

30 minute |REAL PROC minute: minutes END PROC minute; 

31 second |REAL PROC second: seconds END PROC second; 

32 I 

33 date |TEXT PROC date : 

34 I 

35 I IF clock (1) < begin of today OR end of today <= clock (1) 

36 I THEN begin of today := clock (1) ; 

37 I end of today := floor (begin of 

+ I today/day length )«daylength+<iay length; 

38 I today := date (begin of today) 

39 I FI ; 

40 I today 

41 I 

42 lENDPROC date ; 

43 I 
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44 date 

45 
46 
+ 
47 
48 
49 
50 
51 
52 
53 
54 
55 
56 

57 correctkalendaryday 

58 

59 

60 

61 leapyear 

62 

63 

64 

65 

66 

67 calculatemonthandcorre 

68 

69 

70 

71 

72 

73 

74 

75 

76 

77 

78 

79 

80 

81 

82 

83 

84 

85 

86 

87 

88 

89 

90 

91 

92 

93 

94 

95 

96 

97 

98 

99 
100 
101 



TEXT PROC date (REAL CX)NST datum): 

INT VAR year :: int (datum/middle year length), 

day :: int (((datum - datura MOD day length) MOD middle 
year length) / day length) + 1; 

correct kalendaxy day; 

calculate month and correct day; 

result :« daytext; 

result CAT monthtext; 

result CAT yeartext; 

change all (result, ** **, "0") ; 

result . 



correct kalendary day: 

IF day >= 60 AND NOT leapyear 
THEN day INCR 1 FI . 



leapyear: 
IF year MOD 100 = 0 
THEN year MOD 400 « 0 
ELSE year MOD 4 = 0 
FI. 



calculate month and correct day: 
INT VAR month; 
IF day > 182 
THEN IF day > 274 

THEN IF day > 305 

THEN IF day > 335 

THEN month := 12; 

day DECR 335 
ELSE month := 11; 
day DECR 305 

FI 

ELSE month := 10; 
day DECR 274 

FI 

ELSE IF day > 213 

THEN IF day > 244 

THEN month := 9; 

day DECR 244 
ELSE month := 8; 
day DECR 213 

FI 

ELSE month := 7; 
day DECR 182 

FI 

FI 

ELSE IF day > 91 

THEN IF day > 121 

THEN IF day > 152 

THEN month := 6; 

day DECR 152 
ELSE month := 5; 
day DECR 121 

FI 

ELSE month := 4; 
day DECR 91 
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102 I FI 

103 I ' ELSE IF day > 31 

104 I THEN IF day > 60 

105 I THEN month :» 3; 

106 I day DECR 60 

107 I ELSE month := 2; 

108 I day DECR 31 

109 I FI 

110 I ELSE month := 1 FI 

111 I FI 

112 I FI . 

113 I 

114 daytext jdaytext : 

115 I text (day, 2) + 

116 I 

117 monthtext jmonthtext : 

118 I text (month, 2) + 

119 I 

120 yeaptext jyeartext: 

121 I IF 190© <= year AND year < 2000 

122 I THEN text (year - 1900, 2) 

123 I ELSE text (year, 4) 

124 I FI . 

125 I 

126 lEND PROC date; 

127 I 

128 day I TEXT PROC day (REAL CONST datum): 

129 I SELECT int ((datum MOD weeklength) /day length) OF 

130 I CASE 1: "Donnerstag" 

131 I CASE 2: *'Freitag" 

132 I CASE 3: ''Sams tag" 

133 I CASE 4: "Sonntag** 

134 I CASE 5: "Montag** 

135 I CASE 6: "Dienstag" 

136 I OTHERWISE "Mittwoch** ENDSELECT . 

137 I END PROC day; 

138 I 

139 month I TEXT PROC month (REAL CONST datum): 

140 I SELECT int (subtext (date (datum), 4, 5)) OF 

141 I CASE 1: "Januar" 

142 1 CASE 2: "Februar" 

143 I CASE 3: "Marz" 

144 1 CASE 4: "April" 

145 I CASE 5: "Mai" 

146 I CASE 6: "Juni" 

147 I CASE 7: "Juli" 

148 I CASE 8: "August" 

149 I CASE 9: "September" 

150 I CASE 10: "Oktober" 

151 I CASE 11: "November" 

152 I OTHERWISE "Dezember" ENDSELECT . 

153 I 

154 I END PROC month; 

155 I 
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156 year I TEXT PROC year (REAL CONST datum) : 

157 I 

158 I TEXT VAR buffer := subtext (date (datum), 7) ; 

159 I IF LENGTH buffer = 2 

160 I THEN "19** + buffer 

161 I ELSE buffer 

162 I FI . 

163 1 

164 lENDPROC year ; 

165 I 

166 timeofday | TEXT PROC time of day : 

167 I time of day (clock (1)) 

168 lENBPROC time of day ; 

169 I 

170 timeofday |TEXT PROC time of day (REAL CONST value) : 

171 I subtext (time (value MOD daylength) , 1, 5) 

172 lENDPROC time of day ; 

173 1 

174 time I TEXT PROC time (REAL CONST value) : 

175 I time (value, 10) 

176 lENDPROC time ; 

177 I 

178 time I TEXT PROC time (REAL CONST value, INT CONST length) : 

179 I result :=****; 

180 I IF length > 7 

181 1 THEN result CAT hour ; 

182 I result CAT **:** 

183 I FI ; 

184 I result CAT minute ; 

185 I result CAT **:** ; 

186 I result CAT rest ; 

187 I change all (result, ** **, **0**) ; 

188 I result . 

189 I 

190 hour I hour : 

191 j text (int (value/hours), length-8) . 

192 I 

193 minute j minute : 

194 I text (int (value/minutes MOD 60.0), 2) 

195 I 

196 rest [rest : 

197 I text (value MOD minutes, 4, 1) . 

198 I 

199 I END PROC time ; 

200 I 

201 date I REAL PROC date (TEXT CONST datum) : 

202 I split and check datum; 

203 I real (day no) •daylength + 

204 I previous days [month no] + calendary day + 
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205 I floor (real (year no )»iniddleyear length / daylength) May length 

206 1 

207 splitandcheckdatum | split and check datum: 

208 1 INT CX)NST day no : : first no ; 

209 I IF NOT last conversion ok 

210 I THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI; 

211 I 

212 I INT CONST month no : : second no ; 

213 I IF NOT last conversion ok OR month no < 1 OR month no > 12 

214 i THEN errorstop ( "inkorrekte Datumsangabe (Monat) : ** + datum) FI 

215 I 

216 I INT CONST year no :: third no + century; 

217 I IF NOT last conversion ok 

218 I THEN errorstop ("inkorrekte Datumsangabe (Jahr) : " + datum) FI; 

219 I 

220 1 IF day no < 1 OR day no > size of month 

221 I THEN errorstop ( ''inkorrekte Datumsangabe (Tag) : " + datum) FI 

222 I 

223 century | century: 

224 I IF (length (datum) - second pos) <« 2 

225 I THQJ 1900 

226 1 ELSE 0 FI . 

227 I 

228 sizeof month jsize of month: 

229 I SELECT month no OF 

230 1 CASE 1, 3, 5, 7, 8, 10, 12: 31 

231 I CASE 4, 6, 9, 11: 36 

232 I OTHERWISE february size ENDSELECT 

233 I 

234 februarysize | february size: 

235 I IF leapyear 

236 I THEN 29 

237 I ELSE 28 FI . 

238 I 

239 calendaryday jcalendary day: 

240 I IF month no > 2 AND leapyear 

241 I THEN daylength 

242 I ELSE 0.0 FI . 

243 I 

244 leapyear | leapyear: 

245 I year no MOD 4 = 0 AND year no MOD 400 <> 0 . 

246 1 

247 firstno | first no: 

248 1 INT CONST first pos :: pos (datum, "."); 

249 I int (subtext (datum, 1, first pos-D) . 

250 I 

251 secondno [second no: 

252 I INT CONST second pos :: pos (datura, first pos+1); 

253 I int (subtext (datum, first pos + 1, second pos-D) 

254 I 

255 thirdno j third no: 

256 I int (subtext (datum, second pos 1)) 

257 I 
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258 I END PROC date; 

259 I 

260 zixe I HEAL PROC time (TEXT CONST tine; : 

261 I split and check time; 

262 I hour * min sec 

263 I 

264 splitandchccktime j split and check time: 

265 I REAL CONST hour :: hour no * hours; 

266 I ir NOT last conversion ok 

267 I THEN errorstop ( ''inkorrekte Datumsangabe (Stunde) : " + time) PI; 

268 I 

269 I REAL CONST min :: min no • ninutes; 
27© I IP NOT last conversion ok 

271 I THEN errorstop ("inkorrekte Datumsangabe (Minute) : " + time) PI; 

272 I 

273 I REAL CONST sec :: sec no; 

274 I IP NOT last conversion ok 

275 I THEN errorstop ("inkorrekte Datumsangabe (Sekunde) : " + time) PI; 

276 I 

277 I set conversion (hour ok AND min ok AND sec ok) . 

278 I 

279 hourno I hour no: 

280 I INT CONST hour pos :: pos (time, ":"); 

281 I real (subtext (time, 1, hour pos-D) . 

282 I 

283 minno I min no: 

284 I INT VAR min pos :: pos (time, ":", hour pos+1) ; 

285 I IP min pos = 0 

236 1 THEN real (subtext ^time, hour pes * 1, LENGTH time)) 

287 I ELSE real (subtext (tire, hour pos + 1, min pos-D) 

288 I ri . 

289 I 

290 secno I sec no: 

291 I IP min pos = © 

292 I THEN 0.0 

293 1 ELSE real (subtext (time, min pos 1)) 

294 I ri . 

295 I 

296 hourok jhour ok: 0.0 <« hour AfID hour < daylength . 

297 minok I min ok: 0.0 <« min AND min < hours . 

298 secok I sec ok: 0.0 <= sec AND sec < minutes . 

299 I END PROC time; 

300 I 

3©1 I END PACKET datehandling 
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1 I 

2 coramanddialogue »»*«♦♦♦»»» | PACKET command dialogue DEFINES (♦ Autor: J.Liedtke * 

3 I (• Stand: 25.11.83 • 

4 I command dialogue , 

5 I say , 

6 I yes , 

7 I no , 

8 I param position , 

9 I last param , 

10 I Std y 

11 I QUIET , 

12 I quiet : 

13 I 

14 I 

15 I LET up = ''•*3*'** , 

16 I right = ""2"" , 

17 I cr If = *»"i3''"i0'"' , 

18 I param pre 

19 I param post = ♦'•»«)"i3''*'i0«" ; 

20 I 

21 I 

22 ITEXT VAR std param :=*•"; 

23 I 

24 I BOOL VAR dialogue flag ;= TRUE ; 

25 I 

26 I INT VAR param x := 0 ; 

27 I 

28 I 

29 I TYPE QUIET = INT ; 

30 I 

31 quiet I QUIET PROC quiet : 

32 I QUIET: (0) 

33 lENDPROC quiet ; 

34 I 

35 I 

36 commanddialogue | BOOL PROC command dialogue : 

37 I dialogue flag 

38 lENDPROC command dialogue ; 

39 I 

40 commanddialogue | PROC command dialogue ( BOOL CONST status ) : 

41 I dialogue flag := status 

42 lENDPROC command dialogue ; 

43 I 

44 I 

45 yes |BOOL PROC yes (TEXT CONST question) : 

46 I 

47 I IF dialogue flag 

48 I THEN ask question 

49 I ELSE TRUE 

50 I FI . 

51 I 
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52 
53 
54 
55 
56 
57 
58 
59 
60 
61 
62 
63 
64 
65 

66 
67 
68 
69 

70 
71 
72 

73 
74 
75 

76 
77 
78 
79 
8@ 



81 
82 
83 
84 
85 
86 



87 
88 
89 
90 
91 
92 
93 
94 



95 
96 
97 
98 
99 
100 



askquestion 



getanswer 



correctanswer 



posit iveanswer 



skippreviousinputchars 



paramposition 



ask question : 
out (question) ; 
skip previous input chars ; 
out r (j/n) ? **) ; 
get answer ; 
IF correct answer 
THEN out (answer) ; 
out (cr If) ; 
positive answer 
ELSE out C"*?"") ; 

LENGTH question + 9 TIMESOUT '"*8*' 
yes (question) 

FI . 



get answer : 
TEXT VAR answer 
inchar (answer) 



correct answer : 
pos ("jnyJNY", answer) > 



positive answer : 
pos ("jyJY**, answer) > 0 . 



skip previous input chars : 
REP UNTIL incharety = PER 

ENDPROC yes ; 



BOOL PROC no (TEXT CONST question) 

NOT yes (question) 
ENDPROC no ; 

PROC say (TEXT CONST message) : 

IF dialogue flag 
THEN out (message) 

FI 

ENDPROC say ; 

PROC param position (INT CONST x) : 

param x := x 
ENDPROC param position ; 
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101 lastparam |TEXT PROC last paxam : 

102 I 

103 I IF param x > 0 AND online 

104 I THEN out (up) ; 

105 I param x TIMESOUT right ; 

106 I out (param pre) ; 

107 I out (std param) ; 

108 I out (param post) 

109 I FI ; 

110 I std param . 

111 I 

112 lENDPROC last param ; 

113 I 

114 lastparam |PROC last param (TEXT CONST new) : 

115 I std param := new 

116 lENLPROC last param ; 

117 I 

118 std ITEXT PROC std : 

119 I std param 

120 lENDPROC std ; 

121 I 

122 lENDPACKET command dialogue ; 
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1 |(* VERSION 2 06.03.86 •) 

2 the saurushand ling j PACKET thesaurus handling (* Autor: J.Liedtke •) 

3 I 

4 I DEFINES THESAURUS , 

5 I := , 

6 I empty thesaurus , 

7 I insert, (♦ fuegt ein Element ein •) 

8 I delete, (* loescht ein Element falls 
+ I vorhanden«) 

9 I rename, (« aendert ein Element falls 
+ I vorhanden«) 

10 I CONTAINS , (• stent fest. ob enthalten •) 

11 I link , (• index in thesaurus •) 

12 I name , (• name of entry •) 

13 I get , (• get next entry (**" is eof)») 

14 I highest entry : (» highest valid index of thes») 

15 j 

16 I 

17 I TYPE THESAURUS = TEXT ; 

18 I 

19 I LET thesaurus size = 200 , 

20 I nil = 0 , 

21 I niltext = , 

22 I max name length = 80 , 

23 I 

24 I begin entry char = '•♦»0*»'' ^ 

25 I end entry char = *"'l'"' , 

26 I 

27 I nil entry = »»0»»*»j^».»» ^ 

28 I nil name = , 

29 I 

30 I quote = ; 

31 I 

32 I TEXT VAR entry ; 

33 I INT VAR cache index := 0 , 

34 I cache pos ; 

35 I 

36 j 

37 access |PROC access (THESAURUS CONST thesaurus, TEXT CONST name) : 

38 I 

39 I construct entry ; 

40 I IF NOT cache identifies entry 

41 I THEN search through thesaurus list 

42 I FI ; 

43 I IF entry found 

44 I THEN cache index := code (list SUB (cache pos - 1)) 

45 I ELSE cache index := 0 

46 I FI . 

47 I 

48 constructentry j construct entry : 

49 I entry := begin entry char ; 

50 I entry CAT najne ; 

51 j decode invalid chars (entry, 2) ; 

52 I entry CAT end entry char . 

53 I 

54 searchthroughthesaurus | search through thesaurus list : 

55 I cache pos := pos (list, entry) . 

56 I 
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57 cacheidentifiesentry [cache identifies entry : 

58 I cache pos <> 0 AND 

59 I pos (list, entry, cache pos, cache pos + LENGTH entry) = cache pos 
+ I 

60 I 

61 entryfound [entry found : cache pos > 0 . 

62 I 

63 list I list : CONOR (thesaurus) . 

64 I 

65 lENDPROC access ; 

66 I 

67 access |PROC access (THESAURUS CONST thesaurus, INT CONST index) : 

68 I 

69 I IF cache identifies index 

70 I THEN cache index := index ; 

71 I construct entry 

72 I ELSE cache pos := pos (list, code (index) + begin entry char) ; 

73 I IF entry found 

74 I THEN cache pos INCR 1 ; 

75 I cache index := index ; 

76 I construct entry 

77 j ELSE cache index := 0 ; 

78 I entry := niltext 

79 I FI 

80 I FI . 

81 I 

82 constructentry j construct entry : 

83 I entry := subtext (list, cache pos, pos (list, end entry char, 
+ I cache pos) ) . 

84 I 

85 cacheidentifiesindex j cache identifies index : 

86 I subtext (list, cache pos-1, cache pos) » code (index) + begin 
+ I entry char . 

87 I 

88 entryfound | entry found : cache pos > 0 . 

89 I 

90 list I list : CONCR (thesaurus) . 

91 I 

92 lENDPROC access ; 

93 I 

94 I 

95 I 

96 emptythesaurus (THESAURUS PROC empty thesaurus : 

97 I 

98 I THESAURUS : (""i"") 

99 I 

100 lENDPROC empty thesaurus ; 

101 I 
102 
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103 := I OP := (THESAURUS VAR dest, THESAURUS CONST source ) : 

104 I 

105 I CX)NCR (dest) := CONOR (source) . 

106 I 

107 lENTOP := ; 

108 I 

109 (TEXT VAR insert name ; 

110 I 

111 insert |PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR 

■». I index) : 

112 I 

113 I insert name := name ; 

114 I decode invalid chars (insert name, 1) ; 

115 I IF insert name = **** OR LENGTH insert name > max name length 

116 1 THEN index := nil ; errorstop (**Name unzulaessig") 

117 I ELSE insert element 

118 I FI . 

119 I 

120 insertelement [insert element : 

121 I search free entry ; 

122 1 IF entry found 

123 I THEN insert into directory 

124 I ELSE add entry to directory if possible 

125 I FI . 

126 1 

127 searchfreeentry | search free entry : 

128 I access (thesaurus, nil name) . 

129 1 

130 insertintodirectory | insert into directory : 

131 I change (list, cache pos + 1, cache pos, insert name) ; 

132 I index := cache index . 

133 I 

134 addentrytodirectoryifp |add entry to directory if possible : 

135 I INT CONST next free index := code (list SUB LENGTH list) ; 

136 I IF next free index <= thesaurus size 

137 I THEN add entry to directory 

138 I ELSE directory overflow 

139 I FI . 

140 I 

141 addentrytodirectory jadd entry to directory : 

142 I list CAT begin entry char ; 

143 I cache pos := LENGTH list ; 

144 I cache index := next free index ; 

145 I list CAT insert name ; 

146 I list CAT end entry char + code (next free index + 1) ; 

147 j index := cache index . 

148 I 

149 directoryoverflow j directory overflow : 

150 I index ;= nil . 

151 I 

152 entryfound | entry found : cache index > 0 . 

153 I 
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188 
189 
190 
191 
192 
193 
194 

195 
196 
197 
198 
199 
200 



list 



docodeinvalidchars 
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list : CONCR (thesaurus) . 

ENDPRCX: insert ; 



PEK)C decode Invalid chars (TEXT VAR name, INT CXDNST start pos) : 

'31'**', start pos) 



decodedchar 



180 delete 
+ 

181 
182 
183 
184 
185 
186 
187 



delete 



deleteentry 



INT VAR invalid char pos := pos (name, ""0" 
WHILE invalid char pos > 0 REP 

change (name, invalid char pos, invalid ch&r pos, decoded char) 
invalid char pos := pos (name, *»*'0**'', ""si"", invalid char pos) 
PER . 



decoded char : quote + text( code (name SUB invalid char pos)) + 
quote . 



ENDPROC decode invalid chars 



PRCX: insert (THESAURUS VAR thesaurus, TEXT CONST name) 
INT VAR index ; 

insert (thesaurus, name, index) ; 
IF index = nil AND NOT is error 

THEN errorstop ( "THESAURUS -Ueberlauf") 
FI . 

ENDPROC insert ; 



PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR 
index) : 

access (thesaurus, name) ; 
index := cache index ; 
delete (thesaurus, index) . 

ENDPROC delete ; 



PROC delete (THESAURUS VAR thesaurus, INT CONST index) : 

access (thesaurus, index) ; 
IF entry found 

THEN delete entry 
FI . 



delete entry : 

IF is last entry of thesaurus 
THEN cut off as much as possible 
ELSE set to nil entry 
FI . 
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201 settonilentry |set to nil entry : 

202 I change (list, cache pos, cache pos ■»■ LENGTH entry - 1, nil entry) 
+ I 

203 I 

204 cutoffasmuchaspossible jcut off as much as possible : 

205 I WHILE predecessor is also nil entry REP 

206 I set cache to this entry 

207 j PER ; 

208 I list := subtext (list, 1, cache pos - 1) ; 

209 I erase cache . 

210 I 

211 predecessorisalsonilen | predecessor is also nil entry : 

212 I subtext (list, cache pos - 3, cache pos - 2) = nil entry . 

213 I 

214 setcache to thi sentry |set cache to this entry : 

215 I cache pos DECR 3 . 

216 I 

217 erasecache {erase cache : 

218 I cache pos := 0 ; 

219 I cache index := 0 . 

220 I 

221 islastentryof thesaurus |is last entry of thesaurus : 

222 I pos (list, end entry char, cache pos) = LENGTH list - 1 . 

223 I 

224 list I list : CONOR (thesaurus) . 

225 I 

226 entryfound [entry found : cache index > nil . 

227 I 

228 lENDPROC delete ; 

229 I 

230 I 

231 CONTAINS |BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name ) : 

232 I 

233 I IF name = niltext OR LENGTH name > max name length 

234 I THEN FALSE 

235 I ELSE access (thesaurus, mune) ; entry found 

236 I FI . 

237 I 

238 entryfound | entry found : cache index > nil . 

239 I 

240 lENDOP CONTAINS ; 

241 I 

242 rename |PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) : 

243 I 

244 I rename (thesaurus, link (thesaurus, old), new) 

245 I 

246 lENDPROC rename ; 

247 I 
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248 rename |PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST 

+ I new) : 

249 I 

250 I insert name := new ; 

251 I decode invalid chars (insert name, 1) ; 

252 I IF insert name = OR LENGTH insert name > max name length 

253 I THEN errorstop ("Name unzulaessig") 

254 I ELSE change to new name 

255 I FI . 

256 I 

257 change tone wname {change to new name : 

258 I access (thesaurus, index) ; 

259 I IF cache index <> 0 AND entry <> 

260 I THEN change (list, cache pos 1, cache pos + LENGTH entry - 2, 

I insert name) 

261 I FI . 

262 1 

263 list I list : CONCR (thesaurus) . 

264 I 

265 lENDPROC rename ; 

266 1 

267 link |INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) : 

268 I 

269 I access (thesaurus, name) ; 

270 I cache index . 

271 I 

272 lENDPROC link ; 

273 I 

274 name |TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) : 

275 I 

276 I access (thesaurus, index) ; 

277 I subtext (entry, 2, LENGTH entry - 1) . 

278 I 

279 lENDPROC name ; 
260 I 

281 get I PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) : 

282 I 

283 I identify index ; 

284 I REP 

285 I to next entry 

286 I UNTIL end of list COR valid entry found PER . 

287 I 

288 identifyindex j identify index : 

289 I IF index = 0 

290 I THEN cache index := 0 ; 

291 I cache pos := 1 

292 I ELSE access (thesaurus, index) 

293 I FI . 

294 I 

295 tonextentry jto next entry : 

296 I cache pos := pos (list, begin entry char, cache pos +1) ; 

297 I IF cache pos > 0 
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298 I THEN get entry 

299 I ELSE get nil entry 

300 I FI . 

301 I 

302 getentry jget entry : 

303 I cache index INCR 1 ; 

304 I index := cache index ; 

305 I name := subtext (list, cache pos + 1, end entry pos - 1) . 

306 I 

307 getnilentry |get nil entry : 

308 I cache index := 0 ; 

309 I cache pos := 0 ; 

310 I index := 0 ; 

311 I name :=****. 

312 I 

313 endentrypos jend entry pos : pos (list, end entry char, cache pos) . 

314 I 

315 endoflist |end of list : index = 0 . 

316 I 

317 validentryfound | valid entry found : name <> . 

318 I 

319 list I list : (X)NCR (thesaurus) . 

320 I 

321 lENDPROC get ; 

322 1 

323 hlghestentry |INT PROC highest entry (THESAURUS CONST thesaurus) : 

+ I (•840813*) 

324 I 

325 I code (list SUB LENGTH list) - 1 . 

326 I 

327 list I list : CONOR (thesaurus) . 

328 I 

329 lENDPROC highest entry ; 

330 I 

331 lENDPACKET thesaurus handling ; 
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1 |(« VERSION 2 24.02.86 

2 locaLnanager »••»••»»•♦«»• j PACKET local manager (• Autor: J.Liedtke 

3 I 

4 I DEFINES 

5 j create, {» neue lokale Datei einrichten •) 
5 I new, (• 'create* und Datei liefern ») 
7 I old, (• bestehende Datei liefern •) 
e I forget, (• lokale Datei loeschen •) 
9 I exists, (» existiert Datei (lokal) ? ») 

10 I status, (» setzt und liefert Status ») 

11 1 rename, (» Umbenennung *) 

12 I copy , (* Datenraum in Datei kopieren •) 
15 I enter password, (» Passwort einfuehren ») 

14 I write password , 

15 I read password , 

16 I write permission , 

17 I read permission , 

18 I begin list , 

19 I get list entry , 

20 I all : 

21 I 

22 I 

23 I 

24 I LET size = 200 , 

25 I nil = 0 ; 

26 1 

27 I INT VAR index ; 
2S I 

29 I TEXT VAR system write password := , 

30 I system read password := , 

31 I actual password ; 

32 I 

33 IINITFLAG VAR this packet := FALSE ; 

34 I 

35 IDATASPACE VAR password space ; 

36 I 

37 I BOUND ROW size STRUCT (TEXT write, read) VAR passwords ; 

38 1 

39 I 

40 [THESAURUS VAR dir := empty thesaurus ; 

41 I 

42 I ROW size STRUCT (DATASPACE ds, 

43 I BOOL protected, 

44 I TEXT status) VAR crowd ; 

45 I 

46 j 

47 initializeif necessary |PROC initialize if necessary : 

48 I 

49 I IF NOT initialized (this packet) 

50 I THEN system write password 

51 j system read password := ; 

52 I dir := empty thesaurus ; 

53 I password space := nilspace ; 

54 I passwords := password space 

55 I FI 

56 I 

57 lENDPROC initialize if necessary ; 

58 I 

59 1 

60 I 
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61 create |PROC create (TEXT CONST name) : 

62 I 

63 I IF exists (name ) 

64 I THEN error (najne, "existiert bereits**) ; 

65 I index := nil 

66 I ELSE insert and initialize entry 

67 |FI . 

68 I 

69 insertandinitializeent | insert and initialize entry : 

70 I disable stop ; 

71 I insert (dir, name, index) ; 

72 I IF index <> nil 

73 I THEN crowd ( index). ds := nilspace ; 

74 I IF is error 

75 I THEN delete (dir, name, index) ; 

76 I LEAVE create 

77 I FI ; 

78 I status (name, *"*) ; 

79 I crowd (index) .protected := FALSE 

80 I ELIF NOT is error 

81 I THEN errorstop ("zu viele Dateien") 

82 I FI . 

83 I 

84 lENDPROC create ; 

85 I 

86 new |DATASPACE PROC new (TEXT (X)NST name) : 

87 I 

88 I create (name) ; 

89 1 IF index <> nil 

90 I THEN crowd (index).ds 

91 I ELSE nilspace 

92 I FI 

93 I 

94 lENDPRCX: new ; 

95 I 

96 old IDATASPACE PROC old (TEXT CONST name) : 

97 I 

98 I initialize if necessary ; 

99 I index := link (dir, name) ; 

100 I IF index = 0 

101 I THEN error (name, "gibt es nicht**) ; 

102 I nilspace 

103 I ELSE space 

104 I FI . 

105 I 

106 space j space : crowd ( index ).ds . 

107 I 

108 lENDPROC old ; 

109 I 

110 old IDATASPACE PROC old (TEXT CONST name, INT CONST expected type) : 

111 I 

112 I initialize if necessary ; 

113 I index := link (dir, name) ; 

114 I IF index = 0 
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115 I THEN error (name, *'gibt es nicht") ; 

116 I nilspace 

117 1 ELIF type (space) <> expected type 

118 I THEN errorstop ("Datenraum hat falschen Typ") ; 

119 I nilspace 

120 j ELSE space 

121 I FI . 

122 I 

123 space | space : crowd (index).ds . 

124 I 

125 lENDPROC old ; 

126 I 

127 exists I BOOL VBOC exists (TEXT CONST name) : 

128 I 

129 I initialize if necessary ; 

130 I dir CONTAINS name 

131 I 

132 lENDPROC exists ; 

133 1 

134 forget |PROC forget (TEXT CONST name ) : 

135 I 

136 I initialize if necessary ; 

137 I say (^•'*'") ; 

138 I say (name) ; 

139 I IF NOT exists (name) THEN say (**"*• existiert nicht**) 

140 I ELIF yes (**"" loeschen") THEN forget (name, quiet) 

141 I FI . 

142 I 

143 lENDPROC forget ; 

144 I 

145 forget |PROC forget (TEXT CONST name, QUIET CONST q) : 

146 I 

147 I initialize if necessary ; 

148 I disable stop ; 

149 I delete (dir, name, index) ; 

150 I IF index <> nil 

151 I THEN forget ( crowd ( index ).ds ) ; 

152 I crowd (index) .status := *"* 

153 I FI . 

154 I 

155 lENDPROC forget ; 

156 I 

157 forget jPROC forget : 

158 I 

159 I BOOL VAR status := command dialogue ; 

160 I command dialogue (TRUE) ; 

161 I forget (last param) ; 

162 I command dialogue (status) 

163 I 

164 lENDPROC forget ; 

165 I 
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166 status |PROC status (TEXT CONST name, status text) : 

167 I 

168 I initialize if necessary ; 

169 1 INT VAR index := link (dir, name) ; 

170 1 IF index > 0 

171 I THEN crowd ( index) . status := date + ** " + text (status text, 4) 

172 I FI 

173 I 

174 lENDPROC status ; 

175 1 

176 status I TEXT PROC status (TEXT CONST name) : 

177 I 

178 I initialize if necessjury ; 

179 I INT VAR index := link (dir, name) ; 

180 I IF index > 0 

181 I THEN crowd ( index) .status 

182 1 ELSE 

183 I FI 

184 I 

185 lENDPROC status ; 

186 I 

187 status I PROC status (INT CONST pos, TEXT CONST status pattern) : 

188 I 

189 I initialize if necessary ; 

190 I INT VAR index := 0 ; 

191 i WHILE index < highest entry (dir) REP 

192 I index INCR 1 ; 

193 j replace (actual status, pos , status pattern) 

194 I PER . 

195 I 

196 actualstatus [actual status : crowd (index) .status . 

197 I 

198 lENDPROC status ; 

199 I 

200 copy I PROC copy (DATASPACE CONST source, TEXT CONST dest name) : 

201 I 

202 I IF exists (dest name) 

203 I THEN error (dest name, "existiert bereits") 

204 I ELSE copy file 

205 I FI . 

206 I 

207 copyfile |copy file : 

208 I disable stop ; 

209 I create ( dest name ) ; 

210 I INT VAR index := link (dir, dest name) ; 

211 I IF index > nil 

212 I THEN forget (crowd ( index). ds) ; 

213 I crowd ( index). ds := source 

214 I FI 

215 I 

216 lENDPROC copy ; 

217 I 
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218 copy |PE^ copy (TEXT CONST source name, dest name) : 

219 I 

220 I copy (old (source name), dest name) 

221 I 

222 lENDPROC copy ; 

223 I 

224 rename |PROC rename (TEXT (XDNST old name, new name) : 

225 I 

226 I IF exists (new name) 

227 I THEN error (new name, **existiert bereits") 

228 I ELIF exists (old name) 

229 I THEN rename (dir, old naote, new name) ; 

230 I last param (new name) 

231 I ELSE error (old name, "gibt es nicht**) 

232 I FI . 

233 I 

234 lENLPROC rename ; 

235 I 

236 I 

237 beginlist |PR<X: begin list : 

238 I 

239 I initialize if necessary ; 

240 I index := 0 

241 1 

242 lENLPROC begin list ; 

243 I 

244 getlistentry |PROC get list entry (TEXT VAR entry, status text) : 

245 I 

246 I get (dir, entry, index) ; 

247 I IF found 

248 I IliEN status text := crowd ( index) .status ; 

249 I ELSE status text 

250 I FI . 

251 I 

252 found j found : index > 0 . 

253 I 

254 lENDPROC get list entry ; 

255 I 

256 I 

257 writepassword |TEXT PROC write password : 

258 I 

259 f system write password 

260 I 

261 lENDPROC write password ; 

262 I 

263 readpassword |TEXT "PBOC read password : 

264 I 

265 I system read password 

266 I 

267 lENDPROC read password ; 

268 I 
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269 I 

270 enterpassword |PROC enter password (TEXT CONST password) : 

271 I 

272 I initialize if necessary ; 

273 I say ( *'**3*'"5"'') ; 

274 I INT CONST slash pos := pes (password, V**) ; 

275 I ir slash pos = 0 

276 I THEN system write password := password ; 

277 I system read password := password 

278 I ELSE system write password := subtext (password, 1, slash pos-1) 
+ I ; 

279 I system read password := subtext (password, slash pos+1) 

280 I FI . 

281 1 

282 lENDPROC enter password ; 

283 I 

284 enterpassword |PROC enter password (TEXT CONST file name, write pass, read pass) : 

285 I 

286 I INT CONST index := link (dir, file name) ; 

287 I IF index > 0 

288 I THEN set protect password 

289 I FI . 

290 I 

291 setprotectpassword |set protect password : 

292 I IF write pass = AND read pass = **** 

293 I THEN crowd ( index) .protected := FALSE 

294 I ELSE crowd ( index) .protected := TRUE ; 

295 I passwords ( index) .write := write pass ; 

296 I passwords (index). read := read pass 

297 I FI . 

298 I 

299 lENDPROC enter password ; 

300 I 

301 passwordindex |INT PROC password index (TEXT CONST file name) : 

302 i 

303 I initialize if necessary ; 

304 I INT CONST index := link (dir, file name) ; 

305 I IF index > 0 CAND crowd ( index) .protected 

306 I THEN index 

307 I ELSE 0 

308 I FI 

309 I 

310 lENDPROC password index ; 

311 I 

312 readpermission |BOOL PROC read permission (TEXT CONST name, supply password) : 

313 I 

315 I (» for reasons of data security the password check algorithm •) 

316 I (* must not copy parts of the file password into variables •) 

317 I (» located in the standard dataspace! •) 

319 I 

320 I access file password ; 
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321 I file has no password COR (supply password <> AND read password 
+ I match) . 

322 I 

323 readpasswordmatch |read password match : 

324 I file password. read = supply password OR file password. read = **** . 

325 I 

326 accessfilepassword | access file password : 

327 I INT CONST pw index := password index (name) . 

328 I 

329 filepassword |file password : passwords (pw index) . 

330 I 

331 filehasnopassword |file has no password : pw index = 0 . 

332 I 

333 lENDPROC read permission ; 

334 I 

335 writepennission |BOOL PROC write permission (TEXT CONST name, supply password) ; 

336 I 

338 I (» for reasons of data security the password check algorithm •) 

339 I (* must not copy parts of the file password into variables •) 

340 I (» located in the standard dataspace! •) 

341 j ( «»»»<»»»«»»<>»»»<H»*»<»»<M»»«»«-»»«HHH> mU tWWWMWWIIWMi m H WM Mw mn ii n *) 

342 I 

343 I access file password ; 

344 I file has no password COR (supply password <> AND write 
+ I password match) . 

345 I 

346 writepasswordmatch | write password match : 

347 I file pas sword, write = supply password OR file password, write « **" 

348 I 

349 accessfilepassword {access file password : 

350 I INT CONST pw index := password index (name) . 

351 I 

352 filepassword jfile password : passwords (pw index) . 

353 I 

354 filehasnopassword jfile has no password : pw index = 0 . 

355 I 

356 lENDPROC write permission ; 

357 I 

358 all I THESAURUS PROC all : 

359 I 

360 I initialize if necessary ; 

361 I THESAURUS VAR result := dir ; (♦ueberfluessig ab naechstem 
+ I Compiler *) 

362 I result 

363 I 

364 lENDPROC all ; 
365 
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366 error |PROC error (TEXT CONST file name, error text) : 

367 I 

368 I errorstop + file name -»■ ** + error text) 

369 I 

370 lENBPROC error ; 

371 I 

372 lENDPACKET local manager ; 
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PACKET pattern match DEFINES (• Author: 

P.Heyderhoff •) 

(• Date: 

09.06.1986 
•) 

OR, 

any, 

notion, 

bound, 

match, 

matchpos, 

matchend , 

soraefix, 

UNLIKE, 

LIKE : 



(« Operation codes of the internal intermeadiate language: 

*) 



LET 



stopz 
closez 




-0" 
"0" 


n 




closer 
or 


_ nti^n 








oralpha 










open2 
alpha 


= ****5'* 








alphaz 










lenz 










nilz 










starz 










star 










powerz 










powerz© 










notionz 










fullz 


= ""I© 




MM 




boundz 


= ""11 


""0 







(• = any (0) •) 
(« = any •* 1 •) 



LET undefined =0, (• fixleft 

value •) 

forcer =0, (• value 

parameter •) 

delimiter = " !""#$«&*()•+,-./:;<«>?«"_'-"; (♦ for *PROC 

notion* «) 



TEXT OP - (TEXT CONST alphabet ): 
p:= 

INT VAR J; 

FOR j FROM 0 UPTO 255 

REP IF pos ( alphabet, code( j) ) = 0 

THEN p CAT code(j) 

FI 

PER; 
P 

ENDOP -; 
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53 I 

54 OR I TEXT OP OR (TEXT CONST a, b): 

55 I open2 + notnil (a) + closer + notnil (b) + closez 

56 I ENLOP OR; 

57 I 

58 *• I TEXT OP *• (TEXT CONST p, INT CONST x): 

59 I powerz + code (1+x) + notnil (p) * stopz 

60 I ENLOP 

61 I 

62 I TEXT CONST any:= starz; 

63 I 

64 any |TEXT PROC any (INT CONST n): 

65 I TEXT VAR t:= 

66 I replace (t, 1, ABSn); 

67 I lenz + t + starz 

68 I ENDPROC any; 

69 I 

70 any |TEXT PROC any (TEXT CONST a): alphaz + a + starz ENDPROC any; 

71 I 

72 any |TEXT PROC any (INT CONST n. TEXT CONST a): 

73 I TEXT VAR t:= " "; 

74 I replace (t, 1, ABSn); 

75 I lenz + t + alphaz + a + starz 

76 I ENDPROC any; 

77 j 

78 notion |TEXT PROC notion (TEXT CONST t): notionz + notnil(t) + stopz IKDPROC 

+ I notion; 

79 I 

80 notnil [TEXT PROC notnil (TEXT CONST t): 

81 I IF t = 

82 I THEN nilz 

83 I ELSE t 

84 I FI 

85 I ENDPROC notnil; 

86 I 

87 I TEXT CONST bound :» boundz; 

88 I 

89 full ITEXT PROC full (TEXT CONST t): fullz + t + stopz iWDPROC full; 

90 I 

91 match |TEXT PROC match (INT CONST x): 

92 I subtext (p, matchpos(x), matchend(x)) 

93 I ENDPROC match; 

94 I 
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95 matchpos |INT PROC matchpos (INT CONST x): mapos (1 + x MOD 256) ENDPROC 

+ I matchpos ; 

96 I 

97 matchend |INT PROC matchend (INT CONST x): maend (1 + x MOD 256) - 1 

98 I ENDPROC matchend; 

99 I 

100 |(» GLOBAL VARIABLES: 

+ I •) 

101 I 

102 I ROW 256 INT VAR 

103 I (» Table of match registers. Each entry consists of 
+ I two *) 

104 I (» pointers, which points to the TEXT object *t* 

I •) 

105 I mapos, (• points to the beginning of the match 
+ I ») 

106 I maend; (» points to the position after the end of match 

I •) 

107 I 

108 I INT VAR ppos, tpos, (» workpositions in pattern 'p' and text 't' 

I *) 

109 I floatpos, (• accumulation of all pending floatlengths 

I •) 

110 I failpos, (» result of 'PROC in alpha' 

* I •) 

111 I plen, tlen, (* length of pattern 'p' and length of text 
+ I 't' ♦) 

112 I skipcount, (» for track forward skipping 

I *) 

113 I multi, vari; (• for handling of nonexclusive alternatives 

I •) 

114 I 

115 (TEXT VAR p, (•the pattern to be find or some result 
+ I •) 

116 I stack, (• stack of pending assignments 
+ I •) 

117 I alphabet :=*"•; (* result of 'PROC find alpha*, reset to nil 

I •) 

118 I (• after its usage by 'find any' 

I ♦) 

119 I 

120 I BOOL VAR fix, (* text position is fixed and not floating 
+ I •) 

121 I no vari; (• not v«Lriing the order of alternatives 

I •) 

122 I 

123 somefix |TEXT PROC somefix (TEXT CONST pattern): 

124 I 

125 I (* delivers the first text occuring unconditionally in the 
+ I pattern •) 

126 I 

127 I p:= pattern; 

128 I INT VAR J:= 1, n:= 0, k, len:= LENGTH p; 

129 I REP 

130 I SELECT text( subtext (p, j, j+1), 2) ISUB 1 OF 

131 I CASE 1,3,7,9,10,11: J INCR 2 

132 I CASE 2: j INCR 2; n DECR 1 (• condition closed 
+ I *) 
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133 I CASE 4: j INCH 2; n INCH 1 (» condition opened 

+ I •) 

134 I CASE 5: j := pos (p, starz» j+2) + 2 

135 1 CASE 6: j INCR 4 

136 I CASE 8: j INCR 3 

137 I OTHERWISE k:= pos{p, z, J+1) - 1; 

138 I IF k <= 0 THEN k:= 1+len FI; 

139 I IF star found 

140 I THEN change (p, starpos, starpos, star); 

141 I len:= LENGTH p; 

142 I k:= starpos 

143 I FI; 

144 I IF n = 0 CAND ( p SUB k ) <> or CAND k > j 

145 I THEN LEAVE somefix WITH subtext (p,j,k-l) 

146 I ELSE j:=k 

147 I FI 

148 I ENDSELECT 

149 I UNTIL j > len 

150 I PER; 

151 I 

152 I 

153 starfound | star found: 

154 I INT VAR starpos: = pos (p, j); 

155 j starpos > 0 CAND starpos <= k . 

156 I 

157 I ENDPROC somefix; 

158 i 

159 skip IPROC skip (TEXT CONST p, BOOL CONST upto or): 

160 I 

161 I (» skips 'ppos' upto the end of the opened nest, n = nesting 
+ I level ») 

162 I 

163 I INT VAR n:= 0; 

164 I REP 

165 I SELECT text (subtext (p, ppos, ppos+1), 2) ISUB 1 OF 

166 I CASE 1,2: IF n = 0 

167 I THEN LEAVE skip 

168 I PI; 

169 I ppos INCR 2; 

170 I nDECRl 

171 I CASE 3: IF n = 0 CAND upto or 

172 I THEN LEAVE skip 

173 I FI; 

174 I ppos INCR 2 

175 1 CASE 7: ppos INCR 2 

176 I CASE 4,9,10,11: ppos INCR 2; 

177 I n INCR 1 

178 I CASE 5: ppos:= pos (p, starz, ppos+2) + 2 

179 I CASE 6: ppos INCR 4 

180 I CASE 8: ppos INCR 3; 

181 I n INCR 1 

182 I OTHERWISE ppos:= pos(p, z, ppos+1) - 1; 

183 I IF ppos < 0 

184 I THEN ppos:= plen; 

185 i LEAVE skip 

186 I FI 

187 1 ENDSELECT 

188 I PER 

189 I ENDPROC skip; 
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190 I 

191 UNLIKE I BOOL OP UNLIKE (TEXT CONST t» p): NOT ( t LIKE p ) ENDOP UNLIKE; 

192 I 

193 LIKE I BOOL OP LIKE (TEXT CONST t, pattern): 

194 I init; 

195 I BOOL CONST found := find (t.l.l, fixresult, floatresult) ; 

196 I save ; 

197 I found. 

198 I 

199 init j init: no vari:= TRUE; 

200 I vari:= 0; 

201 I tlen:= 1 + LENGTH t; 

202 I p:= full (pattern); 

203 I IF pos (p, bound) > 0 

204 I " THEN 

205 I IF subtext (p, 14, 15) = bound 

206 I THEN p:= subtext (p, 1, 8) powerz0 + subtext (p, 
+ I 16) 

207 I FI ; 

208 I plen:= LENGTH p - 7; 

209 I IF subtext (p, plen, plen+1) = bound 

210 I THEN p:= subtext (p, 1, plen - 1) + stopz + stopz 

211 I FI; 

212 I FI ; 

213 I plen:= LENGTH p + 1; 

214 I INT VAR fixresult, floatresult; 

215 I tpos:= 1; 

216 I floatpos:= 0; 

217 I stack: = *'*'; 

218 I alphabet := **"; 

219 I fix:= TRUE; 

220 j skipcount:= 0; 

221 j multi:= 0. 

222 I 

223 save | save: p:= t 

224 I 

225 I ENDOP LIKE; 

226 I 

227 |(» Realisation of the pattern matching algorithms *find' 

I •) 

228 I 

229 find |BOOL PROC find 

230 I (TEXT CONST t, INT CONST unit, from, INT VAR fixleft, 
+ I floatlen) : 

231 I 

232 I initialize; 

233 I BOOL CONST found := pattern unit; 

234 I SELECT next command ♦ unit OF 

235 I CASE 0,1,2: found 

236 I CASE 3: next; 

237 I find alternative 

238 I OTHERWISE find concatenation 

239 I ENDSELECT . 

240 I 
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241 findalternative | find alternative: 

242 I IF found 

243 I THEN save left position; 

244 1 backtrack; 

245 I IF find pattern CANB better 

246 I THEN note multiplicity 

247 I ELSE back to first one 

248 I n 

249 1 ELSE backtrack multi 

250 I ri . 

251 I 

252 better | better: permutation XOR more left. 

253 I 

254 permutation | permutation: vari MOD 2=1. 

255 I 

256 saveleftposition | save left position: j:= fixleft. 

257 I 

258 more left j more left: j > fixleft. 

259 I 

260 backtrackmulti | backtrack multi: multi := 2 * backmulti + 1; 

261 I vari:= backvari DIV 2; 

262 I find pattern. 

263 I 

264 notemultiplicity 1 note multiplicity: multi := 2 • multi + 1; 

265 I vari:= vari DIV 2; 

266 1 TRUE. 

267 I 

268 backtofirstone | back to first one: backtrack; 

269 I IF find first subpattern 

270 1 THEN skip (p, FALSE); 

271 I note multiplicity 

272 I ELSE errorstop ( '*pattern'' ) ; 

273 I FALSE 

274 I FI. 

275 I 

276 findconcatenation | find concatenation: 

277 I IF found 

278 I THEN IF ppos=plen COR find pattern COR track forward 

279 I COR ( multi > backmulti CAND vari = 0 CAND find variation 

+ I ) 

280 I THEN TRUE 

281 I ELSE backtrack; FALSE 

282 I FI 

283 I ELSE skip (p, TRUE); FALSE 

284 I FI. 

285 I 

286 trackforward | track forward: (• must be performed before 
+ I variation ») 

287 I j:=0; 

288 I last multi := multi; 

289 1 last vari:= vari; 

290 1 WHILE skipcount = 0 

291 I REP IF tlen = tpos 
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292 I THEN LEAVE track forward WITH FALSE 

293 I ri; 

294 I backtrack; 

295 I J INCH 1; 

296 I skipcount:= j 

297 I UNTIL find first subpattern CAND find pattern 

298 I PER; 

299 I j:= skipcount; 
30© I skipcount : =0 ; 

301 I j=0. 

302 I 

303 findvariation | find variation: 

304 I multi:= last multi; 

305 I vari:= last vari; 

306 I FOR k FROM 1 UPTO (multi+1) DIV (backmulti+l) - 1 

307 j REP backtrack with variation; 

308 I IF find first subpattern CAND find pattern 

309 I THEN vari:=0; 

310 I LEAVE find variation WITH TRUE 

311 I FI 

312 I PER; 

313 1 FALSE. 

314 I 

315 backtrackwithvariation | backtrack with variation: 

316 I backtrack ; 

317 I vari:= k. 

318 I 

319 findpattern j find pattern: 

320 I find (t, 1, ppos+forcer, flxresult, floatresult) CAND keep 
+ j result. 

321 I 

322 findfirstsubpattern j find first subpattern: 

323 I find (t, 0, from, fixresult, floatresult) CAND keep result 

324 I 

325 initialize | initialize: 

326 I INT VAR j. 

327 I k, 

328 I fixresult , 

329 I floatresult, 

330 I last multi, 

331 I last vari; 

332 I BOOL CONST backfix:= fix; 

333 1 TEXT CONST backstack:= stack; 

334 I floatlen:= 0; 

335 I ,INT CONST back: = tpos, 

336 I backfloat:= floatpos, 

337 I backskip:x skipcount, 

338 I backmulti:= multi, 

339 I backvari:= vari; 

340 I fixleft:= fixleft0. 

341 I 

342 fixleft© | fixleft©: IF fix THEN back ELSE undefined FI. 

343 I 
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344 backtrack | backtrack: 

345 I fix:= backfix; 

346 I tpos:= back; 

347 I fixleft:= fixleft©; 

348 I floatlen:= 0; 

349 I floatpos:= backfloat; 

350 I stack: = backstack; 

351 I sklpcount:= backskip; 

352 j multi:= backmulti; 

353 I vari:= backvari. 

354 I 

355 keepresult j keep result: 

356 I IF fixleft = undefined 

357 I THEN IF fixresult = undefined 

358 I THEN floatlen INCH floatresult 

359 I ELSE fixleft := fixresult - floatlen; 

360 I floatpos DECR floatlen; 

361 I floatlen: = 0 

362 I FI 

363 I FI ; 

364 I TRUE. 

365 I 

366 pattornunit | pattern unit: 

367 I init ppos; 

368 I SELECT command OF 

369 I CASE 1,2: find end 

370 I CASE 3: find nil 

371 j CASE 4: find choice 

372 I CASE 5: find alphabet 

373 I CASE 6: find fixlength any 

374 I CASE 7: find var length any 

375 I CASE 8: find and store match 

376 I CASE 9: find notion 

377 I CASE 10: find full 

378 I CASE 11: next; find nil 

379 I OTHERWISE find plain text END 
+ I SELECT. 

380 I 

381 initppos | init ppos: ppos:= from -»■ 2. 

382 I 

383 command j command: text (subtext (p, from, from+1), 2) ISUB 1. 

384 I 

385 nextcommand j next command: text (subtext (p, ppos, ppos-^l), 2) ISUB 1. 

386 I 

387 next j next: ppos INCR 2. 

388 I 

389 findend j find end: ppos DECR 2; 

390 I fixleft: = tpos; 

391 I LEAVE find WITH TRUE; 

392 I TRUE. 

393 I 

394 findnil | find nil: ppos DECR 2; 

395 j fixleft := tpos; 

396 I TRUE. 



15/8 



pattern match 



15/8 



Zeile 



»♦♦* ELAN EUMEL 



1.8 »»** 10.11.86 »♦*» pattern match 



397 

398 findchoice 

399 

403 

401 

402 

403 findplaintext 

404 

405 

406 

407 

408 

409 findtextuptonextcomman 

410 

411 

412 

413 

414 

415 

416 

417 

418 

419 

420 

421 

422 starfound 

423 

424 

425 

426 textfound 

427 

428 

429 

430 

431 

432 

433 allowfixpositiononly 

434 

435 

436 

437 

438 

439 

440 allowvariableposition 

441 

442 

443 

444 

445 

446 

447 

448 



find choice: IF find pattern 
THEN next; TRUE 
ELSE next; FALSE 
FI. 



find plain text: find text upto next connnand; 

IF fix THEN allow fix position only 

ELIF text found THEN allow variable position 
ELSE allow backtrack 

FI. 



find text upto next command: 
ppos:= pos (p, z, from + 1); 
IF ppos = 0 
THEN ppos:= plen 
ELSE ppos DECR 1 
FI; 

IF star found 

THEN change (p, starpos, starpos, star); 
plen:= 1 + LENGTH p; 
ppos:= starpos 

FI; 

tpos:= pos (t, subtext (p, from, ppos - 1), tpos). 



star found: 

INT VAR starpos := pos (p, from); 
starpos > 0 CAND starpos <= ppos . 



text found: 

WHILE skipcount > 0 CAND tpos > 0 
REP skipcount DECR 1; 

tpos:= pos (t, subtext (p, from, ppo s -1 ) , tpos+1) 

PER; 

tpos > 0 . 



allow fix position only: 
IF tpos = back 

THEN tpos INCR (ppos-from); TRUE 
ELSE tpos: 3 back; 
from = ppos 

FI. 



allow variable position: 

IF alphabet = COR in alpha (t, back, tpos) 
THEN fix it; 

tpos INCR (ppos-from); 

TRUE 

ELSE tpos:= back; 
FALSE 

FI. 
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449 allowbacktrack | allow backtrack: 

450 I tpos:= back; 

451 I IF from = ppos 

452 I THEN fix it; 

453 I TRUE 

454 I ELSE FALSE 

455 I FI . 

456 I 

457 flndalphabot | find alphabet: 

458 I j:= pos (p, starz, ppos); 

459 I alphabet := subtext (p, ppos, j-1) ; 

460 I ppos := j; 

461 I TRUE. 

462 I 

463 findfixlengthany j find fixlength any: 

464 I get length value; 

465 I find alpha attribut; 

466 I IF alphabet = 

467 I THEN find any with fix length 

468 1 ELSE find any in alphabet with fix length 

469 I FI. 

470 I 

471 getlengthvalue | get length value: 

472 I floatlen:= 3ubtext(p, ppos, ppos+1) ISUB 1; 

473 I ppos INCR 4. 

474 I 

475 findalphaattribut j find alpha attribut: 

476 I IF (p SUB (ppos -2)) = alpha CAND find alphabet 

477 I THEN next 

478 I FI . 

479 I 

480 findanywithfixlength j find any with fix length: 

481 I tpos INCR floatlen; 

482 I IF tpos > tlen 

483 I THEN tpos:= back; 

484 I floatlen :=0; 

485 I FALSE 

486 I ELSE IF fix THEN floatlen := 0 

487 I ELIF floatlen = 0 

408 I THEN fix it (• unlike niltext 6.6. 

^ I •) 

489 I ELSE floatpos INCR floatlen 

490 I FI; 

491 I TRUE 

492 I FI. 

493 I 

494 findanyinalphabetwithf j find any in alphabet with fix length: 

495 I IF first character in alpha 

496 I THEN IF NOT fix THEN fix it FI; 

497 I set fix found 

498 1 ELSE set fix not found 

499 I FI. 

500 I 
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501 firstcharacterinalpha | first character in alpha: 

502 I (fix COR advance) CANT in alpha (t, tpos, tpos+floatlen) . 

503 I 

504 advance | advance: 

505 I FOR tpos FROM back UPTO tlen 

506 I REP IF pos (alphabet, t SUB tpos) > 0 

507 I THEN LEAVE advance WITH TRUE 

508 I FI 

509 j PER; 

510 1 FALSE. 

511 I 

512 fixit 1 fix it: 

513 I fixleft:= back-f loatpos ; 

514 I make fix (back); 

515 I fixleft:= tpos. 

516 I 

517 setfixfound | set fix found; 

518 I tpos INCR floatlen; 

519 I floatlen: = 0; 

520 I alphabet := ""; 

521 1 TRUE. 

522 I 

523 setfixnotfound j set fix not found: tpos:= back; 

524 I alphabet := ****; 

525 I floatlen: = 0; 

526 I FALSE. 

527 I 

528 findvarlengthany j find var length any: IF alphabet = 

529 I THEN really any 

530 I ELSE find varlength any in alphabet 

531 I FI. 

532 j 

533 reallyany 1 really any: IF fix 

534 I THEN fix:= FALSE; 

535 I fixleft:= tpos 
535 I ELIF floatpos « 0 

537 I THEN fixleft:= tpos (• 6.6. 

I *) 

538 I FI; 

539 I TRUE . 

540 I 

541 findvarlengthanyinalph j find varlength any in alphabet: 

542 I IF fix THEN fixleft := tpos FI; 

543 I IF fix CAND pos (alphabet, t SUB tpos) > 0 

544 I COR NOT fix CAND advance 

545 I THEN IF NOT fix THEN fix it FI; 
545 I set var found 

547 ELSE set var not found 

548 I n. 

549 I 

550 setvarfound | set var found: tpos:= end of varlength any; 

551 I alphabet: = ""; 

552 I TRUE. 
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553 setvajrnotfound | set var not found: tpos:= back; 

554 I alphabet := 

555 I FALSE. 

556 endofvarlengthany | end of varlength any: IF NOT in alpha( t,tpos,tlen) 

557 I THEN failpos 

558 j ELSE tlen 

559 I FI. 

560 I 

561 findandstoreraatch | find and store match: get register name; 

562 I IF find pattern 

563 I THEN next; 

564 I store ; 

565 I TRUE 

566 1 ELSE next; 

567 I FALSE 

568 I FI. 

569 I 

570 store | store: IF fix 

571 I THEN mapos (reg):» fixleft; 

572 I maend (reg):= tpos 

573 1 ELSE stack CAT code(floatlen) + 

574 j code(floatpos) + 

^ I code (fixleft) + c 

575 I FI. 

576 I 

577 getregistername | get register name: TEXT CX)NST c:= p SUB (ppos); 

578 I INT VAR reg:« code (c); 

579 I ppos INCR 1. 

580 I 

581 findnotion j find notion: float notion; 

582 I exhaust notion . 

583 I 

584 floatnotion j float notion: y.= back; 

585 I REP IF find pattern 

586 I THEN IF is notion (t, fixleft) 

587 I THEN LEAVE find notion WITH TRUE 

588 I ELir backf ix 

589 I THEN LEAVE float notion 

590 I ELSE go ahead FI 

591 I ELIF j=back 

592 I THEN next; 

593 I LEAVE find notion WITH FALSE 

594 I ELSE LEAVE float notion 

595 I FI 

596 I PER. 

597 I 

598 goahead j go ahead: J INCR 1; 

599 I IF simple THEN j:= max (tpos, j) FI; 

600 I notion backtrack. 

601 I 

602 simple j simple: k:= from; 

603 I REP k := pos (p, z, k+2); 

604 I IF k > ppos-3 

605 I THEN LEAVE simple WITH TRUE 
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606 I ELIF pos (oralpha, p SUB k-1) > 0 

607 I THEN LEAVE simple WITH FALSE 

608 I ri 

609 I PER; 

610 I FALSE. 

611 I 

612 notionbacktrack j notion backtrack: tpos:= J; 

613 1 fix:= backfix; 

614 I fixleft:= fixleft©; 

615 I floatlen:= 0; 

616 I floatpos:= backfloat + tpos - back; 

617 1 stack := backstack; 

618 I ppos:= from + 2 . 

619 I 

620 exhaustnotion j exhaust notion: IF notion expansion 

621 I CX)R multi > backmulti 

622 I CANL no vari 

623 I CAND notion variation 

624 I THEN TRUE 

625 I ELSE backtrack; FALSE 

626 I FI . 

627 I 

628 notionexpansion | notion expansion: j:= 0; 

629 I multi := last multi; 

630 j vari:= last vari; 

631 I WHILE skipcount = 0 

632 I REP skip and try PER; 

633 I j:= skipcount; 

634 I skipcount := 0; 

635 I j = 0. 

636 I 

637 skipandtry | skip and try: backtrack; 

638 I 0 INCH 1; 

639 I skipcount: =j; 
64© I ppos:= from + 2; 

641 1 IF find pattern 

642 I THEN IF is notion (t, fixleft) 

643 1 THEN LEAVE find notion WITH TRUE 

644 I FI 

645 I ELSE next; LEAVE find notion WITH FALSE 

646 I FI . 

647 I 

648 notionvariation | notion variation: no vari:= FALSE; 

649 I last multi := multi; 

650 I last vari:= vari; 

651 I FOR k FROM 1 UPTO (multi+1) DIV (backmulti+1) - 1 

652 I REP backtrack with variation; 

653 1 IF find first subpattern 

654 I THEN no vari:= TRUE; 

655 I LEAVE find notion WITH TRUE 

656 I FI 

657 I PER; 

658 I no vari:= TRUE; 

659 I FALSE. 

660 I 
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661 findfull | find full: 

662 I find pattern CAND (end of line COR exhaust line). 

663 I 

664 endofline | end of line: 

665 I next ; 

666 1 IF fix 

667 I THEN tpos = tlen 

668 I ELSE tpos:= tlen; 

669 I make fix (1 ) ; 

670 I TRUE 

671 I FI. 

672 I 

673 exhaustline j exhaust line: 

674 I IF full expansion COR multi > 0 CAND no vari CAND full 
+ I variation 

675 I THEN TRUE ELSE backtrack; 

676 I FALSE 

677 I FI. 

678 I 

679 fullexpansion | full expansion: 

680 1 j:=0; 

681 I last multi := multi; 

682 I last vari:= vari; 

683 I WHILE skipcount = 0 

684 I REP IF tlen = tpos 

685 I THEN LEAVE full expansion WITH FALSE 

686 I FI ; 

687 I backtrack; 

688 I j INCR 1; 

689 I skipcount := J; 

690 I ppos:=from + 2 

691 I UNTIL find pattern CAND tpos=tlen 

692 I PER; 

693 I j:= skipcount; 

694 I skipcount :=0; 

695 I J=0. 

696 I 

697 fullvariation | full variation: 

698 I no vari:= FALSE; 

699 I multi := last multi; 

700 I vari:= last vari; 

701 1 FOR k FROM 1 UPTO multi 

702 I REP backtrack with variation; 

703 I IF find first subpattern 

704 I THEN no vari:= TRUE; 

705 I LEAVE find WITH TRUE 

706 I FI 

707 I PER; 

708 I no vari:= TRUE; 

709 I FALSE. 

710 I 

711 I ENDPROC find; 

712 I 

713 isnotion |BOOL PROC is notion (TEXT CONST t, INT CONST fixleft): 

714 I ppos INCR 2; 

715 I ( NOT fix 
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716 I COR tpos = tlen 

717 I COR pos (delimiter, t SUB tpos) > 0 

718 I COR pos (delimiter, t SUB tpos-1) > 0 

719 I OOR (t SUB tpos) <= ^'Z" 

720 I CANB (t SUB tpos-1) > "Z** ) 

721 I CAND ( fixleft <= 1 

722 I COR pos (delimiter, t SUB fixleft-1) > 0 

723 I COR pos (delimiter, t SUB fixleft) > 0 

724 I COR (t SUB fixleft) > '*Z" 

725 I CAND (t SUB fixleft-1) <= ^'Z*' ) 

726 i 

727 I END PROC is notion; 

728 I 

729 makefix |PROC make fix (INT CONST back): 

730 I WHILE stack not empty 

731 I REP INT VAR reg:= code (stack SUB top), 

732 I pos:= code (stack SUB top-1), 

733 I len:= code (stack SUB top-3), 

734 ( dis:= code (stack SUB top-2) - floatpos; 

735 I maend(reg):= min (tpos + dis, tlen); (♦ 6.6. 
+ I ♦) 

736 I mapos(reg):= pos or fix or float; 

737 I stack: = subtext (stack,l,top-4) 

738 I PER; 

739 I fix:= TRUE; 

740 I floatpos := 0 . 

741 I 

742 stacknotempty j stack not empty: INT VAR top:= LENGTH stack; 

743 I top > 0. 

744 I 

745 posorfixorfloat | pos or fix or float: 

746 I IP pos = undefined 

747 I THEN IF len = 0 

748 I THEN min (back + dis, tlen) 

749 I ELSE maend(reg) - len 

750 I FI 

751 I ELSE pos 

752 I FI. 

753 I 

754 I ENDPROC make fix; 

755 I 

756 inalpha |BOOL PROC in alpha (TEXT CONST t, INT CONST from, to): 

757 j FOR failpos FROM from UPTO to - 1 

758 I REP IF pos (alphabet, t SUB failpos) = 0 

759 I THEN LEAVE in alpha WITH FALSE 

760 I FI 

761 I PER; 

762 I TRUE 

763 I ENDPROC in alpha; 

764 1 

765 notion |TEXT PROC notion (TEXT CONST t, INT CONST r): notion (t) r 

+ I ENDPROC notion; 

766 I 

767 lENDPACKET pattern match; 
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1 \{n VERSION 35 02.06.86 •) 

2 filehandling | PACKET file handling DEFINES (* Autoren: J.Liedtke, D.Martinek ») 

3 I ( *««*«»»«*«« ) 

4 I 

5 I FILE, 

6 I 

7 I sequential file, 

8 I reorganize , 

9 I input, 

10 I output, 

11 I modify, 

12 I close, 

13 I putline, 

14 I getline, 

15 I put, 

16 I get, 

17 I write , 

18 I line , 

19 I reset, 

20 I down , 

21 I up, 

22 I downety, 

23 I uppety, 

24 I pattern found, 

25 I to first record, 

26 I to line, 

27 I to eof, 

28 I insert record, 

29 I delete record, 

30 I read record, 

31 I write record, 

32 I is first record, 

33 I eof, 

34 I line no, 

35 1 FRANGE, 

36 I set range, 

37 I reset range , 

38 I remove , 

39 I clear removed, 

40 I reinsert, 

41 I max line length, 

42 I edit info, 

43 I line type , 

44 I copy attributes , 

45 I headline , 

46 I put tabs, 

47 I get tabs, 

48 I col, 

49 I word, 

50 I at, 

51 I removed lines, 

52 I exec , 

53 I pos , 

54 I len , 

55 I subtext , 

56 I change , 

57 I lines , 

58 I segments , 

59 I mark , 

60 I mark line no , 

61 I mark col , 

62 I set marked range , 
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63 I split line , 

64 I concatenate line , 

65 I prefix , 

66 I sort , 

67 I lexsort : 

68 I 

69 I 

JQ I ( »<M»«H»<»«» m m « «» W<HMMK»«»«»<M»«HK»«»«»«HHKKMHM»« « « W W « >»««»«H><M»<»«M»»« MWMWWWIilillllWII* 

+ I •*) 

71 !(• 

+ I •) 

72 |(» Terminologie: 
+ I *) 

73 |(» 

+ 1 •) 

74 |(* 

+ I •) 

75 |(» ATOMROW Menge aller Atome eines TILEs. 
+ 1 •) 

76 |(» Die einzelnen Atome haben zwar eine Position 

+ I •) 

77 |(« im Row, aber in dieser Betrachtung keine 

+ I •) 

78 |(» logische Reihenfolge. 
+ I ♦) 

79 |(* 

+ I •) 

80 |(» ATOM Basiselement, kann eine Zeile der Datei und die 

+ I ») 

ei |(« zugehoerige Verwaltungs information aufnehmen 

+ I •) 

82 |(* 

+ I •) 

83 |(» CHAIN Zyklisch geschlossene Kette von Segmenten. 

+ I •) 

84 |(» 

+ I •) 

85 |(« SEGMENT Teilbereich des Atomrows, enthaelt 1 oder raehr 

+ I ♦) 

86 I ( * zusammenhaengende Atoms . 

+ I •) 

87 |(» Jedes Segment hat ein Vorgaenger- und oin 

+ I *) 

88 K* Nachfolgersegment. 
+ I ») 

89 |(« Jedes Segment enthaelt einen logisch zumsamBen- 

+ I «») 

90 |(» haengenden Telle einer Sequence. 

I •) 

91 !(• 

+ I ♦) 

92 |(» SEQUiWCE Logische Folge von Lines. 

+ I •) 

93 |(» Jede Sequence ist Teil einer Chain oder besteht 

+ I •) 

94 |(« vollstaendig daraus: 

+ I •) 

95 |(» 

96 |(» SBGl— SEG2— SEG3~SEG4— SBG5 

-f I * ) 

97 j(« : sequence : 

■I- I *) 
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98 
+ 
99 

+ 

100 
+ 

101 
+ 

102 
+ 

103 
+ 

104 

+ 

105 

-f 

106 
+ 

107 
+ 

108 
+ 

109 
+ 

110 

111 
+ 

112 
+ 

113 
+ 

114 

115 
+ 

116 
+ 

117 
+ 

118 
+ 

119 

+ 

120 
+ 

121 
•f 

122 
+ 

123 

124 

125 

126 
+ 

127 

128 
129 



•) 
•) 
•) 

LINE 
•) 



Die *Reihenfolge* ebenso wie die *Anzahl* der 
Lines ist eine wesentliche Eigenschaft einer 
Sequence . 

Ein Atom als Element ein Sequence betrachtet. 



•) 

• Eigenschaften; 
» 

* Folgende Mengen bilden eine Zerlegung (im math. Sinn) einer 
•) 



gesamten Datei: 
•) 

• ) 

•) 

•) 



used segment chain 
scratch segment chain 
free segment chain 
unused tail 



*) 

Fuer jedes X aus (used, scratch, free) gelten: 
•) 

•) 

'X sequence' ist echte Teilmenge von *X segment chain*. 
•) 

•) 



*chain'.) •) 



(Daraus folgt, es gibt kelne leere 



*X segment chain* ist zyklisch gekettet. 
•) 

♦) 

Alle Atome von *X segment chain* haben definiorten Inhalt. 
•) 

*) 

IMH* 
•») 
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130 I LET file size = 4075 , 

131 I nil = 0 , 

132 I 

133 I free root = 1 , 

134 I scratch root = 2 , 

135 I used root = 3 , 

136 I first unused = 4 ; 

137 I 

138 I 

139 I LET SEQUENCE = STRUCT (INT index, segment begin, segment end, 

140 I INT line no, lines), 

141 I SEGMENT = STRUCT (INT succ, pred, end), 

142 I ATOM » STRUCT (SEGMENT seg, INT type. TEXT line), 

143 I ATOMROW = ROW files ize ATOM, 

144 I 

145 I LIST = STRUCT (SEQUENCE used, INT prefix lines, postfix 
+ I lines, 

146 I SEQUENCE scratch, free, INT unused tail, 

147 I INT mode, col, limit, edit info, mark line, 
■f I mark col, 

148 I ATOMROW atoms); 

149 1 

150 I TYPE FILE = BOUND LIST ; 

151 I 

152 I TYPE FRANCE = STRUCT (INT pre, post, BOOL pre was split, post was 
+ I split); 

153 I 

154 I 

155 := I OP := (FRANGE VAR left, FRANCE CONST right): 

156 I CONOR (left) := CONOR (right) 

157 lENDOP := ; 

158 I 

159 I 

160 := I OP := (FILE VAR left, FILE CONST right): 

161 I EXTERNAL 260 

162 |END OP :=; 

163 I 

164 I 

165 becomes |PROC becomes (INT VAR a, b) : 

166 I INTERNAL 260 ; 

167 I a := b 

168 I END PROC becomes; 

169 I 

170 I 

171 initialize |PROC initialize (FILE VAR f) : 

172 I 

173 I f.used := SEQUENCE : (used root, used root, used root, 1, 0); 

174 I f. prefix lines := 0; 

175 I f. postfix lines := 0; 

176 I f.free := SEQUENCE : (free root, free root, free root, 1, 0)r 

177 I f. scratch := SEQUENCE : (scratch root, scratch root, scratch 
+ I root, 1, 0); 

178 I f. unused tail := first unused; 

179 I 
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180 I f. limit := 77; 

181 I f.edit info := 0; 

182 I f.col := 1 ; 

183 I f.mark line := 0 ; 

184 I f.mark col := 0 ; 

185 I 

186 I INT VAR i; 

187 I FOR i FROM 1 UPTO 3 REP 

188 I root (i).seg := SEGMENT : (i, i, i); 

189 I root (i).line := **" 

190 I PER; 

191 I put Ubs (f, . 

192 I 

193 root I root : f. atoms . 

194 I 

195 [END PROC initialize; 

196 I 

197 I 

+ I «») 

199 !(• 

I •) 

200 |(» Segment Handler (SEGMENTS & CHAINs) 
+ I •) 

201 |{« 

20* ' *^ 

203 1 

204 segs I INT PROC segs (SEQUENCE CONST s. ATOMROW CONST atom) : 

205 I 

206 I INT VAR number of segments := 0 , 

207 I actual segment := s. segment begin ; 

208 I REP 

209 I number of segments INCR 1 ; 

210 I actual segment :^ atom (actual segment) .seg.succ 

211 I UNTIL actual segment « s. segment begin PER ; 

212 I number of segments . 

213 I 

214 lENSPROC segs ; 

215 I 

216 I 

217 nextsegment |PROC next segment (SEQUENCE VAR s, ATOMROW CONST atom) : 

218 I 

219 I disable stop; 

220 I s.line no INCR (s. segment end - s. index •<- 1); 

221 I INT CONST new segment index := actual segment. succ; 

222 I s. segment begin := new segment index; 

223 I s. segment end := new segment. end; 

224 I s. index := new segment index . 

225 I 

226 actualsegment | actual segment : atom (s. segment begin ).seg . 

227 newsegment jnew segment : atom (new segment index). seg . 

228 I 

229 I END PROC next segment; 
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230 I 

231 I 

232 previoussegment |PROC previous segment (SEQUENCE VAR s, ATOMROW CONST atom) : 

233 I 

234 I disable stop; 

235 I s.line no DECR (s. index - s. segment begin +1); 

236 1 INT CONST new segment index := actual segment . pred ; 

237 I s. segment begin := new segment index; 

238 I s. segment end := new segment. end; 

239 I s. index := s. segment end . 

240 I 

241 actualsegment j actual segment : atom (s. segment begin ).seg . 

242 newsegment jnew segment : atom (new segment index). seg . 

243 I 

244 I END PRCX: previous segment; 

245 I 

246 I 

247 splibsegment |PROC split segment (SEQUENCE VAR s, ATOMROW VAR atom) : 

248 I 

249 I disable stop; 

250 I IF not at segment top 

251 I THEN split segment at actual position 

252 I FI . 

253 I 

254 splitsegmentatactualpo j split segment at actual position : 

255 I INT CONST pred index := s. segment begin, 

256 I actual index := s. index, 

257 j succ index :» pred.succ; 

258 I 

259 I actual. pred := pred index; 

260 I actual. succ := succ index; 

261 I actual. end := s. segment end; 

262 I 

263 I pred.succ := actual index; 

264 I pred. end := actual index - 1; 

265 I 

266 I succ. pred := actual index; 

267 I 

268 I s. segment begin := actual index . 

269 I 

270 notatsegmenttop jnot at segment top : s. index > s. segment begin . 

271 I 

272 pred jpred : atom (pred index). seg . 

273 I 

274 actual [actual : atom (actual index). seg . 

275 I 

276 succ jsucc : atom (succ index). seg . 

277 I 

278 I END PROC split segment; 

279 I 

280 I 
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281 joinsegments |PROC join segments (ATOMROW VAR atom, 

282 I INT CONST first index, INT VAR second index) : 

283 I 

284 I disable stop; 

285 I IF first seg.end + 1 = second index 

286 I THEN attach second to first segment 

287 I ELSE link first to second segment 

288 I FI . 

289 I 

290 attachsecondtofirstseg | attach second to first segment : 

291 I first seg.end := second seg.end; 

292 I INT VAR successor of second := second seg.succ; 

293 I IF successor of second = second index 

294 I THEN first seg.succ := first index 

295 I ELSE join segments (atom, first index, successor of second) 

296 I FI; 

297 I second index := first index . 

298 I 

299 linkfirsttosecondsegme |link first to second segment : 

300 I first seg.succ := second index; 

301 I second seg.pred := first index . 

302 I 

303 firstseg | first seg : atom (first index). seg . 

304 secondseg [second seg : atom (second index). seg . 

305 I 

306 lEND PROC join segments; 

307 I 

308 I 

309 deletesegments |PRCX3 delete segments (SEQUENCE VAR from, ATOMROW VAR atom, 

310 I INT CONST first inddx, last index, lines) : 

311 I 

312 I determine surrounding segments and new atom index; 

313 I join surrounding segments; 

314 I update sequence descriptor . 

315 I 

316 determinesurroundingse | determine surrounding segments and new atom index : 

317 I INT VAR pred index := first seg.pred, 

318 I actual index := last seg.succ; 

319 I from. index := actual index . 

320 I 

321 joinsurroundingsegment |join surrounding segments : 

322 I join segments (atom, pred index, actual index) . 

323 I 

324 updatesequencedescrlpt [update sequence descriptor : 

325 I from. segment begin actual Index; 

326 I from. segment end := actual seg.end; 

327 I from. lines DECR lines . 

328 I 

329 actualseg j actual seg : atom (actual index). seg . 



16/7 file handling 16/7 



Zeile •••• ELAN EUMEL 



1,8 10.11.86 file handling 



330 flrstseg | first seg : atom (first index). seg . 

331 lastseg |last seg : atom (last index). seg . 

332 I 

333 I END PROC delete segments; 

334 I 

335 I 

336 Insertsegments |PROC insert segments (SEQUENCE VAR into, ATOMROW VAR atom, 

337 I INT CONST first index, last index, lines) : 
336 I 

339 I Join into sequence and new segments; 

340 I update sequence descriptor . 

341 I 

342 Joinintosequenceandnew Ijoin into sequence and new segments : 

343 I INT VAR actual index into. index, 

344 I pred index := actual seg.pred; 

345 I Join segments (atom, last index, actual index); 

346 I actual index := first index; 

347 I Join segments (atom, pred index, ewtual index) . 

348 I 

349 updatesequencedescript j update sequence descriptor : 

350 I into. index := first index; 

351 I into. segment begin actual index; 

352 I into. segment end := actual seg. end; 

353 1 into. lines INCR lines . 

354 I 

355 actualseg | actual seg : atom (actual index). seg . 

356 I 

357 I END PROC insert segments; 

358 I 

359 I 

360 nextatom |PROC next atom (SEQUENCE VAR s, ATOMROW CONST atom) : 

361 I 

362 I IF s.line no <= s. lines 

363 I THEN to next atom 

364 I ELSE errorstop ("'down' nach Datelende") 

365 I FI . 

366 I 

367 tonextatom jto next atom : 

368 I disable stop; 

369 I IF s. index = s. segment end 

370 I THEN next segment (s, atom) 

371 I ELSE s. index INCR 1; 

372 I s.line no INCR 1 

373 I FI 

374 I 

375 I END PROC next atom; 

376 I 

377 I 

378 nextatoms |PROC next atoms (SEQUENCE VAR s, ATOMROW CONST atom, INT CONST 

+ I times) : 

379 I 
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360 1 INT CONST destination line := min (s.line no + times, s. lines + 1) 

361 I jump upto destination segment; 

382 I position within destination segment . 

363 I 

384 Jumpuptodestinationseg I jump upto destination segment : 

365 I WHILE s.line no •»- length of actual segments tail < destination 
+ I line REP 

366 I next segment (s, atom); 
387 I PER . 

366 I 

369 positionwithindestinat [position within destination segment : 

390 I disable stop; 

391 I s. index INCR (destination line - s.line no); 

392 I s.line no := destination line . 

393 I 

394 lengthofactualsegments | length of actual segments tail : s. segment end - s. index . 

395 I 

396 I END PROC next atoms; 

397 I 

398 I 

399 prevlousatom |PROC previous atom (SEQUENCE VAR s, ATOMROW CONST atom) : 

400 I 

401 I IF s.line no > 1 

402 I THEN to previous atom 

403 I ELSE errors top ("'up' am Dateianfang") 

404 I FI . 

405 I 

406 topreviousatora |to previous atom : 

407 I disable stop; 

406 I IF s. index = s. segment begin 

409 I THEN previous segment (s, atom) 

410 I ELSE s. index DECR 1; 

411 I s.line no DECR 1 

412 j FI 

413 I 

414 (END PROC previous atom; 

415 I 

416 I 

417 previousatoms JPROC previous atoms (SBCJUENCE VAR s, ATOMROW CONST atom, INT CONST 

* I times) : 

418 1 

419 I INT CONST destination line := max (1, s.line no - times); 

420 I jump back to destination segment; 

421 I position within destination segment . 

422 I 

423 jumpbacktodestlnatlons jjump back to destination segment : 

424 I WHILE s.line no - length of actual segments head > destination 
+ I line REP 

425 I previous segment (s, atom); 

426 I PER . 

427 I 
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428 posltionwlthindestinat | position within destination segment : 

429 I disable stop; 

430 I s. index LECR (s.line no - destination line); 

431 I s.line no := destination line . 

432 I 

433 lengthofactualsegments | length of actual segments head : s. index - s. segment begin . 

434 I 

435 I END PROC previous atoms; 

436 1 

437 I 

438 I TEXT VAR pre, pat, pattern©; 

439 I INT VAR last search line ; 

440 I 

441 searchdown |PROC search down (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST 

+ I pattern , 

442 I INT CONST max lines, INT VAR column) : 

443 I 

444 I INT CONST start col := column , 

445 I start line := s.lineno ; 

446 I last search line := min (s. lines, s.lineno + max lines) ; 

447 I pre:= somefix (pattern) ; 

448 I pattern© := pattern »» 0 ; 

449 I down in atoms (s, atom, pre, column); 

450 I IF NOT (last search succeeded CAND like pattern) 

451 I THEN try again 

452 I FI ; 

453 I last search succeeded :«= TRUE ; 

454 I column := matchpos (0) . 

455 I 

456 tryagain jtry again: 

457 I WHILE s.line no < last search line 

458 I REP next atom (s, atom) ; 

459 I column := 1 ; 

460 I down in atoms (s, atom, pre, column); 

461 I IF last search succeeded CAND like pattern 

462 I THEN LEAVE try again 

463 I FI 

464 I PER; 

465 I column := 1 + LENGTH record; 

466 I last search succeeded := FALSE ; 

467 I LEAVE search down. 

468 I 

469 likepattern |like pattern : 

470 I correct position ; 

471 I pat := any (column-1) ; 

472 I pat CAT any ; 

473 I pat CAT pattern© ; 

474 I pat CAT any ; 

475 I record LIKE pat . 

476 I 

477 correctposition [correct position : 

478 I IF s.lineno = start line 

479 I THEN column := start col 

480 I ELSE column := 1 

481 I FI . 

482 I 
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483 record [record : atom (s. index) .line . 

484 I 

485 lENDPROC search down ; 

486 I 

487 downinatoms |PROC down in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST 

+ I pattern, 

488 I INT VAR column) : 

489 I 

490 I last search succeeded :» PALSE ; 

491 I search forwards in actual line ; 

492 I IF NOT found AND s.line no < last search line 

493 I THEN search in following lines 

494 1 FI ; 

495 I IF found 

496 I THEN last search succeeded := TRUE 

497 I ELSE set column behind last char 

498 I FI . 

499 I 

500 setcolumnbehindlastcha |set column behind last ch«u: : 

501 I column :« LENGTH atom (s. index) .line + 1 . 

502 I 

503 searchforwardsinactual | search forwards in actual line : 

504 I IF pattern <> 

505 I THEN column pos (atom ( s. index) . line » pattern, column) 

506 I ELIF column > LENGTH atom (s. index) .line 

507 I THEN column :« 0 

508 I FI . 

509 I 

510 searchinfollowinglines [search in following lines : 

511 I next atom (s, atom) ; 

512 I IF pattern = 

513 I THEN column :« 1 ; 

514 I LEAVE search in following lines 

515 I FI ; 

516 I REP 

517 I search forwards through segment ; 

518 I update file position forwards ; 

519 I IF found OR s.line no = last search line 

520 I THEN LEAVE search in following lines 

521 I ELSE next segment (s, atom) 

522 I FI 

523 I PER . 

524 I 

525 searchforwardsthroughs | search forwards through segment : 

526 I INT VAR search index := s. index , 

527 I last index := min (s. segment end, s.index+(last search line-s.line 
+ I no ) ) ; 

528 I REP 

529 I column pos (atom (search index). line, pattern) ; 

530 I IF found OR search index = last Index 

531 I THEN LEAVE search forwards through segment 

532 I FI ; 

533 I search index INCR 1 

534 I PER . 

535 I 
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536 updatefilepositionforw | update file position forwards : 

537 I disable stop ; 

538 I s.line no INCH (search index - s. index) ; 

539 I s. index := search index ; 

540 I enable stop . 

541 I 

542 found | found : column > 0 . 

543 I 

544 lENDPROC down in atoms ; 

545 I 

546 prefix |TEXT PROC prefix (TEKT CONST pattern) : 

547 I 

548 I INT VAR invalid char pos := pos (pattern, ""o*"*, ""31*"', 1) ; 

549 I SELECrr invalid char pos OF 

550 I CASE 0 : pattern 

551 I CASE 1 : 

552 I OTHERWISE : subtext (pattern, 1, invalid char pos - 1) 

553 1 ENDSELECT . 

554 I 

555 lENDPROC prefix ; 

556 I 

557 searchup |PROC search up (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST 

+ I pattern, 

558 1 INT CONST max lines, INT VAR column) : 

559 I 

560 I last search line := max (1, s.lineno - max lines) ; 

561 I pre:= prefix (pattern); 

562 I pattern0 := pattern «» 0; 

563 I remember start point ; 

564 I up in atoms (s, atom, pre, column); 

565 I IF NOT (last search succeeded CANS last pattern in line found) 

566 I THEN try again 

567 I FI; 

568 I last search succeeded := TRUE ; 

569 I column := matchpos (0) . 

570 I 

571 tryagain | try again: 

572 I WHILE s.lineno > last search line OR column > 1 

573 j REP previous atom (s, atom); 

574 I column := LENGTH record ; 

575 I up in atoms (s, atom, pre, column); 

576 I IF last search succeeded CAND last pattern in line found 

577 I THEN LEAVE try again 

578 I FI 

579 I PER; 

580 I column := 1; 

581 I last secorch succeeded := FALSE ; 

582 I LEAVE search up. 

583 I 

584 refflofflberstcirtpolnt | remember start point : 

585 I INT VAR c:= column, r:= s.lineno;. 

586 I 
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587 las tpatterninline found | last pattern in line found : 

588 I column := 2 ; 

589 1 WHILE like pattern CAND right of start REP 

590 I column :* matchpos (0) +1 

591 I PER ; 

592 I column DECR 1 ; 

593 I like pattern CAND right of start . 

594 I 

595 likepattern | like pattern : 

596 I pat :» any (column-1) ; 

597 I pat CAT any ; 

598 I pat CAT pattern© ; 

599 I pat CAT any ; 

600 I record LIKE pat . 

601 I 

602 rightofstart | right of start : (r > s.lineno COR c >= matchpos(0)) . 

603 record | record : atom (s. index) .line . 

604 I 

605 lENDPROC search up ; 

606 I 

607 upinatoBs |PROC up in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST 

-I- I pattern, 

608 I INT VAR column) : 

609 I 

610 I last search succeeded FALSE ; 

611 I search backwards in actual line ; 

612 I IF NOT found AND s.line no > last search line 

613 I THEN search in proceeding lines 

614 I FI ; 

615 I IF found 

616 I THEN last search succeeded := TRUE 

617 I ELSE column := 1 

618 I FI . 

619 I 

620 searchbackwardsinactua j search backwards in actual line : 

621 I IF pattern = **** 

622 I THEN LEAVE search backwards in actual line 

623 I FI ; 

624 I INT VAR last pos , new pos :- 0 ; 

625 I REP 

626 I last pos : = new pos ; 

627 I new pos := pos (atom (s. index) .line, pattern, last pos+1) ; 

628 I UNTIL new pos = 0 OR new pos > column PER ; 

629 I column := last pos . 

630 I 

631 searchinpreceedingline | search in proceeding lines : 

632 I previous atom (s, atom) ; 

633 1 IF pattern = 

634 I THEN column := LENGTH atom (s. index) .line + 1 ; 

635 I last search succeeded := TRUE ; 

636 1 LEAVE search in proceeding lines 

637 1 FI ; 

638 I REP 

639 I search backwards through segment ; 

640 I update file position backwards ; 
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641 
642 
643 
644 
645 
646 

647 searchbackwardsthrough 
648 
649 
+ 

650 
651 
652 
653 
654 
655 
656 
657 
658 
659 
660 
661 

662 updatefilepositionback 

663 

664 

665 

666 

667 

668 found 

669 

670 

671 

672 

673 



674 patternfound 

675 

676 

677 

678 

679 



680 deleteatom 

681 
682 
683 
684 
685 
686 
687 

688 deleteactualatotn 

689 

690 

691 

692 

693 



IF found OR s.line no = last search line 
THEN LEAVE search in preceeding lines 
ELSE previous segment (s, atom) 

FI 
PER . 



search backwards through segment : 
INT VAR search index := s. index , 

last index := max (s. segment begin, s.index-( s.line no-last search 
line)); 

REP 

new pos := 0 ; 
REP 

column := new pos ; 

new pos := pos (atom (search index). line » pattern, column+1) ; 
UNTIL new pos = 0 PER ; 
IF found OR search index = last index 

THEN LEAVE search backwards through segment 
FI ; 

search index DECR 1 
PER . 



update file position backwards : 
disable stop ; 

s.line no DECR (s. index - search index) ; 
s . index : = search index ; 
enable stop . 



found : column > 0 . 
ENDPROC up in atoms ; 
BOOL VAR last search succeeded ; 



BOOL PROG pattern found : 

last search succeeded 
ENDPROC pattern found ; 



PROC delete atom (SECJUENCE VAR used, free, ATOMROW VAR atom) : 
disable stop; 

IF used. line no <= used. lines 

THEN delete actual atom 

ELSE errorstop ( '"delete' am Dateiende") 
FI . 



delete actual atom : 
position behind actual free segment; 
split segment (used, atom); 
INT VAR actual index := used. index; 
cut off tail of actual used segment; 

delete segments (used, atom, actual index, actual index, 1); 
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694 I insert segments (free, atom, actual index, actual index, 1) . 

695 j 

696 positionbehindactualfr | position behind actual free segment : 

697 I IF free. line no <= free. lines 

698 I THEN next segment (free, atom) 

699 I FX . 

700 I 

701 cutofftailofactualused jcut off tail of actual used segment : 
7G2 I IF actual index <> used. segment end 

703 I THEN used. index INCH 1; 

704 I split segment (used, atom); 

705 I used. index DECR 1 

706 I FI . 

707 I 

708 I END PROC delete atom; 

709 I 

710 I 

711 insertatom |PROC insert atom (SEQUENCE VAR used, free, INT VAR unused, ATOMROW 

+ I VAR atom) : 

712 I 

713 I disable stop; 

714 I split segment (used, atom); 

715 j IF free. lines > 0 

716 I THEN insert new atom from free sequence 

717 I ELIF unused <» file size 

718 I THEN insert new atom from unused tail 

719 I ELSE errorstop ( *'FILE-Ueberlauf " ) 

720 I FI . 

721 I 

722 insertnewatomfromfrees [insert new atom from free sequence : 

723 I get a free segments head; 

724 I make this atom to actual segment; 

725 I transfer from free to used chain . 

726 I 

727 getafree segment shead |get a free segments head : 

728 I IF actual free segment is root segment 

729 I THEN previous segment (free, atom) 

730 I FI; 

731 I position to actual segments head . 

732 I 

733 positiontoactualsegmen (position to actual segments head : 

734 j INT VAR actual index := free. segment begin; 

735 ( free. line no DECR (free. index - actual index); 

736 I free. index := actual index . 

737 I 

738 makethisatomtoactualse jmake this atom to actual segment : 

739 I IF free. segment end > actual index 

740 i THEN free. index INCR 1; 

741 I split segment (free, atom); 

742 I free. index DECR 1 

743 I FI . 

744 I 
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745 transferfromfreetoused | transfer from free to used chain : 

746 I delete segments (free, atom, actual index, actual index, 1); 

747 I insert segments (used, atom, actual index, actual index, 1); 

748 I atom (actual index). line := "** . 

749 I 

750 insertnewatomfromunuse (insert new atom from unused tail : 

751 I actual index := unused; 

752 j atom (actual index ).seg := 

753 I SEGMENT: (actual index, actual index, actual 
+ I index) ; 

754 I atom (actual index). line := 

755 I insert segments (used, atom, actual index, actual index, 1); 

756 I unused INCH 1 . 

757 I 

758 actualfreesegmentisroo [actual free segment is root segment : free. segment begin = free 
+ I root . 

759 i 

760 I END VBOC insert atom; 

761 I 

762 I 

763 insertnext |PROC insert next (SEQUENCE VAR used, free, INT VAR unused, ATOMROW 

+ I VAR atom, 

764 I TEXT CONST record) : 

765 I 

766 I IF used. lire no > used. lines 

767 I THEN insert atom (used, free, unused, atom) 

768 I ELIF actual position before unused nonempty atomrow part 

769 I THEN forward and insert atom by simple extension of used atomrow 
+ I part 

770 I ELSE next atom (used, atom); 

771 I insert atom (used, free, unused, atom) 

772 I FX; 

773 I atom (used. index) .line := record . 

774 I 

775 forwardandinsertatomby | forward and insert atom by simple extension of used atomrow part : 

776 I used, line no II'CR 1; I 

777 I used. lines INCH 1; 

778 I used. index INCR 1; 

779 I used. segment end INCR 1; 

780 I atom (used. segment begin) . seg. end INCR 1; 

781 I unused INCR 1 . 

782 I 

783 actualpositionbeforeun [actual position before unused nonempty atomrow part : 

784 I used. index = unused - 1 AND unused part not empty . 

785 I 

786 unusedpartnotempty | unused part not empty : unused <= file size . 

787 I 

788 I END PROC insert next; 

789 I 

790 I 

791 transf ersubsequence | PROC transfer subsequence ( SECJUENCE VAR source , dest , 

792 I ATOMROW VAR atom, INT CONST size) : 

793 I 
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794 
795 
796 
797 
798 
799 
800 
801 

802 maxkbeginofsourcepart 

803 

804 

805 

806 

807 markendofsourcopart 

808 

809 

810 

811 

612 

813 splitdestinationsequen 

814 

815 

816 transferpart 

817 

818 

819 

820 

821 

822 

823 

824 

825 

826 

827 

828 
+ 

829 
+ 

830 
+ 

831 
■f 

832 
833 
834 
835 
836 
837 
838 
839 
840 
841 
842 
843 
844 
845 
846 



IF size > 0 

THEN INT VAR subsequence size := min (size, source. line no); 
mark begin of source part; 
mark end of source part; 
split destination sequence; 
transfer part 

FI . 



mark begin of source part : 

previous atoms (source, atom, subsequence size - 1); 

split segment (source, atom); 

INT CONST first := source . segment begin . 



mark end of source part : 

next atoms (source, atom, subsequence size - 1); 
INT COtiST last := source . segment begin; 
next atom (source, atom); 
split segment (source, atom) . 



split destination sequence : 
split segment (dest, atom) . 



[transfer part : 
I disable stop; 

I delete segments (source, atom, first, last, subsequence size); 
source. line no DECR subsequence size; 

insert segments (dest, atom, first, last, subsequence size); 
next atoms (dest, atom, subsequence size - 1) . 

END PROC transfer subsequence; 




LET file type = 1003 , 

file type 16 = 1002 , 

closed » 0, 

inp = 1, 

outp = 2, 

mod = 3, 

end = 4, 

max limit = 16000, 

super limit = 16001; 
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847 I 

848 I TYPE TRANSPUTDIRECTION = INT; 

849 I 

850 I 

851 input I TRANSPUTDIRECTION PROC input : 

852 I TRANSPUTDIRECTION : (inp) 

853 I END PROC input; 

854 I 

855 I 

856 output I TRANSPUTDIRECTION PROC output : 

857 I TRANSPUTDIRECTION : (outp) 

858 I END PROC output; 

859 I 

860 I 

861 modify | TRANSPUTDIRECTION PROC modify : 

862 I TRANSPUTDIRECTION : (mod) 

863 I END PROC modify; 

864 I 

865 I 

866 I FILE VAR result file; 

867 I 
668 I 

869 sequent ialfile |FILE PROC sequential file (TRANSPUTDIRECTION CONST mode, 

870 I DATASPACE CONST ds) : 

871 I IF type (ds) . file type 

872 1 THEN result := ds 

873 I ELIF type (ds) < 0 

874 I THEN result := ds; type (ds, file type); initialize (result file) 

875 I ELSE enable stop; errors top (**Datenraum hat falschen Typ") 

876 I FI; 

877 I reset (result file, mode); 

878 I result file . 

879 I 

88© result [result : CONOR (result file) . 

881 I 

882 I END PROC sequential file; 

883 I 

884 I 

885 sequentialfile |FILE PROC sequential file (TRANSPUTDIRECTION CONST mode, TEXT CONST 

+ I name) : 

886 I 

887 I IF exists (name) 

888 I THEN get dataspace if file 

889 1 ELIF CONOR (mode) <> inp 

890 I THEN get new file space 

891 I ELSE errorstop ("***'*' -»-narae+*'*'** gibt es nicht") ; enable stop 

892 I FI; 

893 I update status if necessary; 

894 I reset (result file, mode); 

895 I result file . 

896 I 
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897 getdataspaceiffile |get dataspace if file : 

898 I IF type (old (name)) = file type 16 

899 I THEN reorganize (name) 

900 I FX ; 

901 I result := old (name, file type) ; 

902 I IF is 170 file 

903 I THEN result. col 1 ; 

904 I result. mark line :> 0 ; 

905 I result. mark col := 0 

906 I FI . 

907 I 

908 isl70file |is 170 file : result. mark col < 0 . 

909 I 

910 getnewfilespace jget new file space : 

911 I result := new (name); 

912 I IF NOT is error 

913 I THEN type (old (name), file type); initialize (result file) 

914 I FI . 

915 I 

916 updatestatusifnecessar {update status if necessary : 

917 I IF CONOR (mode) <> inp 

918 I THEN status (name, ""); headline (result file, name) 

919 I FI . 

920 I 

921 result | result : CONOR (result file) . 

922 I 

923 [END PROG sequential file; 

924 I 

925 I 

926 reset |PROC reset (FILE VAR f) : 

927 I 

928 I IF f.mode = end 

929 I THEN reset (f, input) 

930 1 ELSE reset (f, TRANSPUTDIRECTION: (f.mode) ) 

931 I FI . 

932 I 

933 lENDPROC reset ; 

934 I 

935 reset |PROC reset (FILE VAR f, TRANSPUTDIRECTION CONST mode) : 

936 1 

937 I IF f.mode <> mod OR new mode <> mod 

938 I THEN f.mode := new mode ; 

939 I initialize file index 

940 I FI . 

941 I 

942 initializefileindex | initialize file index : 

943 I IF new mode = outp 

944 I THEN to line without check (f, f .used. lines) ; 

945 I col := super limit 

946 I ELSE to line without check (f, 1); 

947 I col := 1 ; 

948 I IF new mode = inp AND file is empty 

949 I THEN f.mode := end 
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950 I ri 

951 I FI . 

952 I 

953 fileisempty |file is empty : f .used. lines = 0 . 

954 I 

955 newmode jnew mode : CONOR (mode) . 

956 1 

957 col I col : CONOR (CONCR (f)).col . 

958 I 

959 I END PROC reset; 

960 I 

961 I 

962 Input I PROC input (FILE VAR f) : 

963 I 

964 I reset (f» input) . 

965 I 

966 I END PROC input; 

967 I 

968 1 

969 output I PROC output (FILE VAR f) : 

970 I 

971 I reset (f, output) 

972 I 

973 I END PROC output; 

974 I 

975 I 

976 modify I PROC modify (FILE VAR f) : 

977 1 

978 I reset (f, modify) 

979 I 

980 I END PROC modify; 

981 I 

982 I 

983 close I PROC close (FILE VAR f) : 

984 I 

985 I f.mode := closed . 

986 i 

987 I END PROC close; 

988 I 

989 I 

990 checkmode |PROC check mode (FILE CONST f, INT CONST mode) : 

991 I 

992 I IF f.mode = mode 

993 I THEN LEAVE check mode 

994 1 ELIF f.mode = closed 

995 I THEN errorstop (**Datei zu!**) 

996 1 ELIF f.mode = mod 

997 I THEN errorstop ( **unzulaessiger Zugriff auf modify-FILE") 

998 I ELIF mode = mod 
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999 


1 THEN 


errorstop ("Zugriff nur auf modify-FILE zulaessig**) 


100® 


1 ELIF 


f.mode s end 


1001 


1 THEN 


errorstop ( "Leseversuch nach Dateiende") 


1002 


1 ELIF 


mode = inp 


1003 


1 THEN 


errorstop ( **Leseversuch auf output-FILE** ) 


1004 


1 ELIF 


mode = outp 


1005 


1 THEN 


errorstop ("Schreibversuch auf input-FILE") 


1006 


1 FI . 




1007 






1008 


lEND PROC 


check mode; 


1009 






1010 







1011 tolinewlthoutcheck 

1012 

1013 

1014 

1015 

1016 

1017 

1018 

1019 

1020 

1021 

1022 



toline 



toflrstrecord 



1023 
1024 
1025 
1026 
1027 
1028 
1029 
1030 



1031 
1032 
1033 
1034 
1035 
1036 
1037 



1038 
1039 
1040 
1041 
1042 
1043 
1044 



1045 putllne 

1046 

1047 

1048 

1049 



toeof 



PRCX3 to line without check (FILE VAR f , INT CONST destination line) 

INT CONST distance := destination line - f. used. line no; 
IF distance > 0 

THEN next atoms (f.used, f. atoms, distance) 
ELIF distance < 0 

THEN previous atoms (f.used, f. atoms, - distance) 
FI . 

END PROC to line without check; 



PROC to line (FILE VAR f , INT CONST destination line) 
check mode (f, mod); 

to line without check (f, destination line) 
END PROC to line; 



PROC to first record (FILE VAR f) : 

to line (f, 1) 
END PROC to first record; 

PROC to eof (FILE VAR f) : 

to line (f, f.used. lines + 1) . 
END PROC to eof; 

PROC putline (FILE VAR f, TEXT CONST word) 

write (f, word); 
col := super limit . 
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1050 col I col : CONCR (CONCR (f)).col . 

1051 I 

1052 I END PROC putline; 

1053 I 

1054 I 

1055 deleterecord |PROC delete record (FILE VAR f) : 

1056 1 

1057 I check mode (f, mod); 

1058 I delete atom (f.used, f.free» f. atoms) . 

1059 I 

1060 I END PROC delete record; 

1061 I 

1062 I 

1063 insertrecord |PROC insert record (FILE VAR f) : 

1064 I 

1065 I check mode (f, mod); 

1066 I insert atom (f.used, f.free, f. unused tail, f. atoms) . 

1067 I 

1068 I END PROC insert record; 

1069 I 

1070 I 

1071 down I PROC down (FILE VAR f) : 

1072 I 

1073 I check mode (f, mod); 

1074 j next atom (f.used, f. atoms) . 

1075 1 

1076 I END PROC down ; 

1077 I 

1078 up IPROC up (FILE VAR f) : 

1079 I 

1080 I check mode (f, mod); 

1081 I previous atom (f.used, f. atoms) . 

1082 I 

1083 I END PROC up ; 

1084 I 

1085 down I PROC down (FILE VAR f , INT CONST n) : 

1086 I 

1087 I to line (f, lineno (f) + n) 

1088 I 

1089 lENDPROC down ; 

1090 I 

1091 up I PROC up (FILE VAR f , INT CONST n) : 

1092 I 

1093 I to line (f, lineno (f) '- n) 

1094 1 

1095 lENDPROC up ; 

1096 1 

1097 I 
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1098 writerecord |PROC write record (FILE VAR f, TEXT CONST record) : 

1099 I 

1100 I check mode (f, mod); 

1101 j IF not at eof 

1102 j THEN f. atoms (f .used. index) . line :« record 

1103 I ELSE errors top write* nach Dateiende**) 

1104 I FI . 

1105 I 

1106 notateof |not at eof : f. used. line no <= f. used. lines . 

1107 I 

1108 I END PROC write record; 

1109 I 

1110 I 

nil readrecord |PROC read record (FILE CONST f, TEXT VAR record) : 

1112 I 

1113 I check mode (f, mod); 

1114 I record := f. atoms (f .used. index) .line . 

1115 I 

1116 I END PROC read record; 

1117 I 

1118 j 

1119 line IPROC line (FILE VAR f) : 

1120 I 

1121 I IF mode = end 

1122 1 THEN errorstop ( *'Leseversuch nach Dateiende") 

1123 I ELIF mode = inp 

1124 I THEN next atom (f.used, f. atoms); col :« 1; check eof 

1125 I ELIF mode = outp 

1126 ( THEN IF col <= max limit 

1127 I THEN col := super limit 

1128 I ELSE append empty line 

1129 I n 

1130 I FI . 

1131 I 

1132 appendemptyline | append empty line : 

1133 I insert next (f.used, f.free, f. unused tail, f. atoms, "*') . 

1134 I 

1135 col I col : CONCR (CONCR (f)).col . 

1136 I 

1137 mode |mode : CONCR (CONCR (f)).mode . 

1138 I 

1139 checkeof | check eof : 

1140 I IF eof (f) THEN mode := end FI . 

1141 I 

1142 I END PROC line; 

1143 1 

1144 I 

1145 line |PROC line (FILE VAR f, INT CONST lines) : 

1146 I 

1147 I INT VAR i; FOR i FROM 1 UPTO lines REP line (f) PER 

1148 I 
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1149 I END PROC line; 

1150 1 

1151 I 

1152 getline |PROC getline (FILE VAR f, TEXT VAR text) : 

1153 I 

1154 I check mode (f, inp); 

1155 I text := subtext (record, f.col); 

1156 I IF f. used. line no >= f. used. lines 

1157 I THEN f.mode := end ; 

1158 I set end of file 

1159 I ELSE to next line ; 

1160 I f.col 1 

1161 I FI . 

1162 I 

1163 tonextline jto next line : 

1164 I next atom (f.used, f. atoms) . 

1165 I 

1166 setendoffile jset end of file : 

1167 I f.col := LENGTH record + 1 . 

1168 1 

1169 record j record : f. atoms (f .used. index) . line . 

1170 I 

1171 I END PROC getline; 

1172 I 

1173 I 

1174 isfirstrecord |BOOL PROC is first record (FILE CONST f) : 

1175 I 

1176 I check mode (f, mod); 

1177 I f.used. line no = 1 . 

1178 I 

1179 I END PROC is first record; 

1180 I 

1181 I 

1182 eof I BOOL PROC eof (FILE CONST f ) : 

1183 I 

1184 I IF line no < lines THEN FALSE 

1185 I ELIF line no = lines THEN col > LENGTH record 

1186 I ELSE TRUE 

1187 I FI . 

1188 I 

1189 lineno jline no : f.used. line no . 

1190 lines | lines : f.used. lines . 

1191 col I col : f.col . 

1192 record jrecord f. atoms (f.used. index) .line . 

1193 I 

1194 I END PROC eof; 

1195 1 

1196 I 
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1197 lineno |INT PROC line no (FILE CONST f) : 

1198 I 

1199 I f. used. line no . 

1200 I 

1201 I END PROC line no; 

1202 1 

1203 I 

1204 linetype |PROC line type (FILE VAR f, INT CONST t) : 

1205 I 

1206 j f. atoms (f .used. index) .type := t . 

1207 I 

1208 lENDPROC line type ; 

1209 I 

1210 linetype |INT PROC line type (FILE CONST f) : 

1211 I 

1212 I f. atoms (f .used. index) .type . 

1213 I 

1214 lENDPROC line type ; 

1215 I 

1216 I 

1217 put I PROC put (FILE VAR f , TEXT CONST word) : 

1218 I 

1219 I check mode (f, outp); 

1220 I IF col + LENGTH word > f. limit 

1221 I THEN append new line 

1222 I ELSE record CAT word 

1223 I FI; 

1224 I record CAT 

1225 I col := LENGTH record + 1 . 

1226 I 

1227 appendnewline | append new line : 

1228 I insert next (f.used, f.free, f. unused tail, f. atoms, word) . 

1229 I 

1230 record j record : f. atoms (f.used. index) .line . 

1231 col I col : f.col . 

1232 I 

1233 I END PROC put; 

1234 I 

1235 I 

1236 put I PROC put (FILE VAR f, INT CONST value) : 

1237 I 

1238 I put (f, text (value)) 

1239 I 

1240 I END PROC put; 

1241 I 

1242 I 

1243 put I PROC put (FILE VAR f, REAL CONST real) : 

1244 I 

1245 I put (f, text (real)) 
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1246 
1247 
1248 
1249 



1250 
1251 
1252 
1253 
1254 
1255 
1256 
1257 
1258 

1259 
1260 
1261 

1262 

1263 
1264 
1265 
1266 
1267 



1268 
1269 
1270 
1271 
1272 
1273 
1274 
1275 
1276 

1277 
1278 
1279 
1280 

1281 
1282 
1283 

1284 
1285 

1286 
1287 
1288 
1289 
1290 
1291 
1292 

1293 
1294 



appendnewline 

record 
col 



get 



skipseparators 



isseparator 



wordfound 



getword 



separatorfound 



END PROC put; 



PROC write (FILE VAR f, TEXT CONST word) 

check mode (f, outp) ; 

IF col + LENGTH word - 1 > f. limit 

THEN append new line 

ELSE record CAT word 
FI; 

col := LENGTH record + 1 . 



append new line : 

insert next (f.used, f.free, f. unused tail, f. atoms, word) 



record : f. atoms (f.used. index) .line . 
col : f.col . 
END PRCX; write; 

PROC get (FILE VAR f, TEXT VAR word. TEXT CONST separator) : 

check mode (f, inp); 
skip separators; 
IF word found 
THEN get word 

ELSE try to find word in next line 
FI . 



skip separators : 

INT CONST separator length := LENGTH separator; 
WHILE is separator REP col INCR separator length PER . 



is separator ; 

subtext (record, col, col + separator length - 1) = separator 



word found : col <= LENGTH record . 



get word : 

INT VAR end of word := pos (record, separator, col) - 1; 
IF separator found 

THEN get text upto separator 

ELSE get rest of record 
FI . 



separator found : end of word >« 0 . 
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1295 gettextuptoseparator |get text upto separator : 

1296 I word := subtext (record, col, end of word); 

1297 I col := end of word + separator length + 1; 

1298 I IF col > LENGTH record THEN line (f) FI . 

1299 I 

1300 getres to f record |get rest of record : 

1301 I word := subtext (record, col); line (f) . 

1302 1 

1303 record jrecord : f. atoms (f .used. index) .line . 

1304 col Icol : f.col . 

1305 I 

1306 trytofindwordinnextlin jtry to find word in next line : 

1307 1 line (f); IF eof (f) THEN word := ELSE get (f, word, separator) 
* I FI . 

1308 I 

1309 I END PROC get; 

1310 1 

1311 I 

1312 get I PROC get (FILE VAR f , TEXT VAR word, INT CONST max length) : 

1313 I 

1314 I check mode (f, inp) ; 

1315 I IF word is only a peirt of record 

1316 I THEN get text of certain length 

1317 I ELSE get rest of record 

1318 I FI . 

1319 I 

1320 wordisonlyapartofrecor jword is only a part of record : 

1321 I col <= LENGTH record - max length . 

1322 I 

1323 gettextofcertainlength jget text of certain length : 

1324 I word := text (record, max length, col); 

1325 1 col INCR max length . 

1326 I 

1327 getrestof record |get rest of record : 

1328 I word := subtext (record, col); line (f) . 

1329 I 

1330 record jrecord : f. atoms (f .used. index) .line . 

1331 col I col : f.col . 

1332 I 

1333 I END PROC get; 

1334 I 

1335 I 

1336 get I PROC get (FILE VAR f, TEXT VAR word) : 

1337 I 

1338 I get (f, word, " *•) 

1339 I 

1340 I END PROC get; 

1341 I 

1342 I 
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1343 I TEXT VAR number word; 

1344 I 

1345 I 

1346 get IPROC get (FILE VAR f, INT VAR number) : 

1347 I 

1348 I get (f, number word); 

1349 I number := int (number word) 

1350 I 

1351 I END PROC get; 

1352 I 

1353 I 

1354 get I PROC get (FILE VAR f » REAL VAR number) : 

1355 ( 

1356 I get (f, number word); 

1357 I number := real (number word) 

1358 I 

1359 I END PROC get; 

1360 I 

1361 I 

1362 I TEXT VAR spilt record ; 

1363 I INT VAR indentation ; 

1364 I 

1365 splitline |PROC split line (FILE VAR f, INT CONST split col) : 

1366 I 

1367 I split line (f, split col, TRUE) 

1368 I 

1369 lENDPROC split line ; 

1370 I 

1371 splitline |PROC split line (FILE VAR f, INT CONST split col, BOOL CONST note 

+ I indentation ) : 

1372 I 

1373 I IF note indentation 

1374 I THEN get indentation 

1375 j ELSE indentation := © 

1376 I FI ; 

1377 I get split record ; 

1378 I insert split record and indentation ; 

1379 I cut off old record . 

1380 I 

1381 getindentation |get indentation : 

1382 I indentation := pos (actual record, *"'33*'",''"254**",1) - 1 ; 

1383 j IF indentation < 0 OR indentation >= split col 

1384 j THEN indentation := split col - 1 

1385 I FI . 

1386 I 

1387 getsplitrecord |get split record : 

1388 I split record := subtext (actual record, split col, max limit) 

1389 I 

1390 Insertsplitrecordandin | insert split record and indentation : 

1391 I down (f) ; 

1392 I insert record (f) ; 
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1393 I INT VAR i ; 

1394 I FOR i FROM 1 UPTO indenUtion REP 

1395 I actual record CAT " ** 

1396 I PER ; 

1397 I actual record CAT split record ; 

1398 I up (f) . 

1399 I 

1400 cutoffoldrecord |cut off old record : 

1401 I actual record := subtext (actual record, 1, split col-1) . 

1402 I 

1403 actualrecord [actual record : f. atoms ( f .used. index) . line . 

1404 I 

1405 lENDPROC split line ; 

1406 I 

1407 concatenateline |PROC concatenate line (FILE VAR f, BOOL CONST delete blanks) : 

1408 I 

1409 I down (f) ; 

1410 I split record := actual record ; 

1411 I IF delete blanks 

1412 I THEN delete leading blanks 

1413 I FI ; 

1414 I delete record (f) ; 

1415 I up (f) ; 

1416 I actual record CAT split record . 

1417 I 

1418 delete leadingblanks (delete leading blanks : 

1419 I INT CONST non blank col := pos (split record, ""SS**", •"'254''**, 1) 

1420 I IF non blank col > 0 

1421 I THEN split record := subtext (split record, non blank col) 

1422 I FI . 

1423 I 

1424 actualrecord [actual record : f. atoms (f .used. index) .line . 

1425 I 

1426 [ENDPROC concatenate line ; 

1427 I 

1428 concatenateline [PROC concatenate line (FILE VAR f) : 

1429 I concatenate line (f, TRUE) 

1430 [ENDPROC concatenate line ; 

1431 I 

1432 reorganize [PROC reorganize : 

1433 I 

1434 [ reorganize (last param) 

1435 I 

1436 [END PROC reorganize; 

1437 I 

1438 I 

1439 [TEXT VAR file record ; 

1440 I 
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1441 reorganize 

1442 
1443 
1444 
1445 
1446 
1447 
1448 
1449 
1450 
1451 
1452 
1453 
1454 
1455 
1456 
1457 

1458 reorganize new to new 

1459 

1460 

1461 

1462 

1463 

1464 

1465 

1466 

1467 

1468 

1469 

1470 

1471 

1472 

1473 reorganizeoldtonew 

1474 

1475 

1476 

1477 

1478 

1479 

1480 

1481 

1482 

1483 

1484 

1485 

1486 

1487 

1488 

1489 

1490 

1491 

1492 

1493 

1494 

1495 

1496 

1497 

1498 



PROC reorganize (TEXT CONST file name) : 
enable stop ; 

FILE VAR input file, output file; 
DATASPACE VAR scratch space; 

INT CONST type of dataspace := type (old (file name)) ; 
INT VAR counter; 

last param (file name); 

IF type of dataspace = file type 

THEN reorganize new to new 
ELIF type of dataspaw;e = file type 16 

THEN reorganize old to new 

ELSE errorstop ("Datenraum hat falschen Typ") 
FI; 

replace file space by scratch space . 



reorganize new to new : 

input file : = sequential file (input, file name); 

disable stop ; 

scratch space := nilspace ; 

output file := sequential file (output, scratch space); 
copy attributes (input file, output file) ; 

FOR counter FROM 1 UPTO 9999 
WHILE NOT eof (input file) REP 
cout (counter); 

getline (input file, file record); 
putline (output file, file record); 
check for interrupt 
PER . 



reorganize old to new : 

LET OLDRECORD = STRUCT (INT succ, pred, x, y, TEXT record); 
LET OLDFILE = BOUND ROW 4075 OLDRECORD; 
LET dateianker = 2, freianker = 1; 
INT VAR index := dateianker; 

OLDFILE VAR old file := old (file name); 
disable stop; 

scratch space :« nilspace; 

output file := sequential file (output, scratch space); 
I get old attributes ; 

say CDatei wird in 1.7-Format gewandelt: ") ; 

FOR counter FROM 1 UPTO 9999 
WHILE NOT end of old file REP 
cout (counter); 
index := next record; 
file record := record of old file ; 
IF pos (file record, *'*'128*'", ""250****, 1) > 0 
THEN change special chars 
1 FI ; 

I putline (output file, file record); 

check for interrupt 
I PER . 
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1499 getoldat tributes |get old attributes : 

1500 I get old headline ; 

1501 I get old limit and tabs . 

1502 I 

1503 getoldheadline jget old headline : 

1504 I headline (output file, old file { date ianker) .record) . 

1505 I 

1506 getoldlimitandtabs |get old limit and tabs : 

1507 I file record := old file (freianker) .record ; 

1508 I max line length (output file, int (subtext (file record, 11, 15)) 
+ I ; 

1509 I put tabs (output file, subtext (file record, 16)) . 

1510 1 

1511 changespecialchars j change special chars : 

1512 I change all (file record, *"'193'**', •"'214'*") (• Ae •) ; 

1513 I change all (file record, ""207"", ""215"") (• Oe *) ; 

1514 I change all (file record, ""213"", ""216"") (* Ue •) ; 

1515 1 change all (file record, ""225"", ""217"") (• ae *) ; 

1516 I change all (file record, ""239"", ""218"") (• oe •) ; 

1517 j change all (file record, ""245"", ""219"") (* ue «) ; 

1518 I change all (file record, ""235"", ""220"") (♦ k *) ; 

1519 I change all (file record, ""173"", ""221"") (* - •) ; 

1520 1 change all (file record, ""163"", ""222"") (» fis •) ; 

1521 1 change all (file record, ""160"", ""223"") (» blank *) ; 

1522 I change all (file record, ""194"", ""251"") (♦ eszet •) . 

1523 I 

1524 endofoldfile jend of old file : next record = dateianker . 

1525 I 

1526 nextrecord |next record : old file ( index). succ . 

1527 1 

1528 recordofoldfile jrecord of old file : old file ( index) .record . 

1529 I 

1530 checkforinterrupt | check for interrupt : 

1531 I INT VAR size, used ; 

1532 I storage (size, used) ; 

1533 I IF used > size 

1534 I THEN errorstop ( "Speicherengpass") 

1535 I FI ; 

1536 I IF is error 

1537 I THEN forget (scratch space) ; LEAVE reorganize 

1538 I FI . 

1539 I 

1540 replacefilespacebyscra [replace file space by scratch space : 

1541 I headline (output file, file name); 

1542 I forget (file name, quiet) ; 

1543 I type (scratch space, file type); 

1544 I copy (scratch space, file name); 

1545 I forget (scratch space) . 

1546 I 

1547 I END PROC reorganize; 

1548 I 

1549 1 
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1550 setrange |PROC set range (FILE VAR f, INT CONST start line, start col, 

1551 I FRANGE VAR old range) : 

1552 I 

1553 I check mode (f, mod); 

1554 I IF valid restriction parameters 

1555 I THEN prepare last line ; 

1556 I prepare first line ; 

1557 I save old range ; 

1558 I set new range 

1559 I ELSE errors top ("FRANGE ungueltig") 

1560 I FI . 

1561 I 

1562 valldrestrictionparame | valid restriction parameters : 

1563 I start line > 0 AND start col > 0 AND start before or at actual 
+ I point . 

1564 I 

1565 start be foreoratactualp [start before or at actual point : 

1566 I start line < line no (f) OR 

1567 1 start line = line no (f) AND start col <= col (f) . 

1568 I 

1569 preparelastline [prepare last line : 

1570 I INT VAR last line ; 

1571 I IF col (f) > 1 

1572 I THEN split line (f, col(f), FALSE) 

1573 I FI . 

1574 I 

1575 preparefirstline | prepare first line : 

1576 I IF start col > 1 

1577 I THEN split sUrt line ; 

1578 I FI . 

1579 I 

1580 splitstartline | split start line : 

1581 I INT VAR old line no := line no (f) ; 

1582 I to line (f, start line) ; 

1583 1 split line (f, start col, FALSE) ; 

1584 I to line (f, old line no -»■ 1) . 

1585 I 

1586 saveoldrange |save old range : 

1587 I old range. pre :« f. prefix lines ; 

1588 I old range. post := f. postfix lines . 

1589 I 

1590 setnewrange |set new range : 

1591 I get pre lines ; 

1592 I get post lines ; 

1593 j disable stop ; 

1594 I f. prefix lines INCR pre lines ; 

1595 I f. postfix lines INCR post lines ; 

1596 1 f. used. lines DECR (post lines + pre lines) ; 

1597 I f. used. line no DECR pre lines . 

1598 I 

1599 getprelines |get pre lines : 

1600 I INT VAR pre lines ; 

1601 I IF start col = 1 

1602 j THEN old range. pre was split :« FALSE ; 
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1603 I pre lines := start line - 1 

1604 I ELSE old range. pre was split := TRUE ; 

1605 I pre lines := start line 

1606 I FI . 

1607 I 

1608 getpostlines jget post lines : 

1609 I INT VAR post lines ; 

1610 I IF col (f) = 1 

1611 I THEN old range. post was split := FALSE ; 

1612 I post lines ;= lines (f) - line no (f) +1 

1613 I ELSE old range. post was split := TRUE ; 

1614 I post lines := lines (f) - line no (f) 

1615 I FI . 

1616 I 

1617 (END PROC set range; 

1618 I 

1619 I 

1620 setrange |PROC set range (FILE VAR f , FRANCE VAR new range) : 

1621 I 

1622 I check mode (f, mod); 

1623 1 INT CONST pre add := prefix - new range. pre, 

1624 I post add := postfix - new range. post; 

1625 I IF pre add < 0 OR post add < 0 

1626 I THEN errorstop ( •'FRANCE ungueltig") 

1627 I ELSE set new range; 

1628 I undo splitting if necessjtry ; 

1629 I make range var invalid 

1630 1 FI . 

1631 I 

1632 setnewrange |set new range : 

1633 I disable stop; 

1634 I prefix DECR pre add; 

1635 I postfix DECR post add; 

1636 I used. line no INCR pre add; 

1637 I used. lines INCR (pre add + post add) . 

1638 I 

1639 undosplittingifnecessa jundo splitting if necessary ; 

1640 I IF new range. pre was split 

1641 I THEN concatenate first line 

1642 I FI ; 

1643 I IF new range. post was split 

1644 I THEN concatenate last line 

1645 I FI . 

1646 I 

1647 concatenatefirstline j concatenate first line : 

1648 I INT VAR old line := line no (f) ; 

1649 1 to line (f, pre add) ; 

1650 I concatenate line (f, FALSE) ; 

1651 I to line (f, old line - 1) . 

1652 I 

1653 concatenate lastline [concatenate last line : 

1654 I old line := line no (f) ; 

1655 I to line (f, lines (f) - post add) ; 

1656 I concatenate line (f, FALSE) ; 

1657 I to line (f, old line) . 
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1658 I 

1659 makerangevarinvalid |make range var invalid : 

1660 I new range. pre := maxint . 

1661 I 

1662 used jused : f.used . 

1663 prefix | prefix : f. prefix lines . 

1664 postfix I postfix : f. postfix lines . 

1665 I 

1666 I END PROC set range; 

1667 I 

1668 resetrange |PROC reset range (FILE VAR f) : 

1669 I 

1670 I FRANCE VAR complete ; 

1671 I complete. pre := 0 ; 

1672 I complete. post := 0 ; 

1673 I complete. pre was split := FALSE ; 

1674 j complete. post was split := FALSE ; 

1675 I set range (f, complete) 

1676 I 

1677 lENDPROC reset range ; 

1678 I 

1679 remove I PROC remove (FILE VAR f, INT CONST size) : 

1680 I 

1681 I check mode (f, mod); 

15Q2 I transfer subsequence (f.used, f. scratch, f. atoms, size) . 

1683 I 

1684 I END PROC remove; 

1685 I 

1686 I 

1687 clearremoved |PROC clear removed (FILE VAR f) : 

1688 I 

1689 I check mode (f, mod); 

1690 I transfer subsequence (f. scratch, f.free, f. atoms, f. scratch. lines) 

+ I 

1691 ! 

1692 I END PROC clear removed; 

1693 I 

1694 I 

1695 reinsert I PROC reinsert (FILE VAR f) : 

1696 I 

1697 I check mode (f, mod); 

1698 I transfer subsequence (f. scratch, f.used, f. atoms, f. scratch. lines) 
+ I 

1699 I 

1700 I END PROC reinsert; 

1701 I 

1702 I 
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1703 copyattributes |PROC copy attributes (FILE CONST source file, FILE VAR dest file) : 

1704 I 

1705 I dest. limit := source . limit ; 

1706 I dest. atoms (free root). line := source. atoms (free root). line ; 

1707 I dest. atoms (scratch root). line := source. atoms (scratch root). line 
+ I ; 

1708 I dest. edit info := source. edit info . 

1709 I 

1710 dest I dest : CX)NCR (CONOR (dest file)) . 

1711 source | source : CONOR (CONCR (source file)) . 

1712 I 

1713 lENDPROC copy attributes ; 

1714 I 

1715 I 

1716 maxlinelength | INT PROC max line length (FILE CONST f) : 

1717 I 

1718 I f. limit . 

1719 I 

1720 I END PROC max line length; 

1721 1 

1722 I 

1723 maxline length |PROC max line length (FILE VAR f , INT CONST new limit) : 

1724 I 

1725 I IF new limit > 0 AND new limit <= max limit 

1726 I THEN f. limit := new limit 

1727 I FI . 

1728 I 

1729 I END PROC max line length; 

1730 I 

1731 I 

1732 headline |TEXT PROC headline (FILE CONST f) : 

1733 I 

1734 I f. atoms (free root). line . 

1735 I 

1736 I END PROC headline; 

1737 I 

1738 I 

1739 headline |PROC headline (FILE VAR f, TEXT CONST head) : 

1740 I 

1741 I f. atoms (free root). line := head . 

1742 I 

1743 I END PROC headline; 

1744 I 

1745 I 

1746 gettabs |PROC get tabs (FILE CONST f, TEXT VAR tabs) : 

1747 I 

1748 I tabs := f. atoms (scratch root). line . 

1749 I 

1750 I END PROC get tabs; 

1751 I 
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1752 I 

1753 puttabs |PROC put tabs (FILE VAR f, TEXT CONST tabs) : 

1754 1 

1755 I f. atoms (scratch root). line := tabs . 

1756 I 

1757 I END PROC put tabs; 

1758 I 

1759 I 

1760 editinfo I INT PROC edit info (FILE CONST f) : 

1761 I 

1762 I f.edit info . 

1763 I 

1764 I END PROC edit info; 

1765 I 

1766 I 

1767 editinfo |PROC edit info (FILE VAR f. INT CONST info) : 

1768 I 

1769 I f.edit info := info . 

1770 I 

1771 [END PROC edit info; 

1772 I 

1773 I 

1774 lines |INT PROC lines (FILE CONST f) : 

1775 I 

1776 I f. used. lines . 

1777 I 

1778 I END PROC lines; 

1779 I 

1780 I 

1781 removedlines |INT PROC removed lines (FILE CONST f) : 

1782 I 

1783 I f. scratch. lines . 

1784 I 

1785 I END PROC removed lines; 

1786 I 

1787 I 

1788 segments | INT PROC segments (FILE CONST f) : 

1789 I 

1790 I segs(f .used, f. atoms) + segs( f. scratch, f. atoms) + 
+ I segs(f .free, f. atoms) - 2 . 

1791 I 

1792 lENDPROC segments ; 

1793 I 

1794 I 

1795 col I INT PROC col (FILE CONST f) : 

1796 I 

1797 I f.col 

1798 I 
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1831 
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1838 

1839 
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1844 exec 



1845 



word 



at 



column 



record 



ENDPROC col ; 



PROC col (FILE VAR f, INT CONST new column) : 

IF new column > © 
THEN f.col := new column 

FI 

ENDPROC col ; 



TEXT PROC word (FILE CONST f) : 

word (f, " ") 
ENDPROC word ; 

TEXT PROC word (FILE CONST f, TEXT CONST delimiter) : 

INT VAR del pos := pos (f, delimiter, col (f)) ; 
IF del pos = 0 

THEN del pos := len (f) 1 
FI ; 

subtext (f, col (f), del pos - 1) 
ENDPROC word ; 

TEXT PROC word (FILE CONST f, INT CONST max length) : 

subtext (f, col (f). col (f) + max length - 1) 
ENDPROC word ; 

BOOL PROC at (FILE CONST f . TEXT CONST word) : 

pat := any (column-1) ; 
pat CAT word ; 
pat CAT any ; 
record LIKE pat . 

column : f.col . 

record : f. atoms (f .used. index). line . 
ENDPROC at ; 

PROC exec (PROC (TEXT VAR, TEXT CONST) proc, FILE VAR f, TEXT CONST 

t) : 
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1846 I proc (record, t) . 

1847 I 

1848 record jrecord : f. atoms (f .used. index) . line . 

1849 I 

1850 I END PROC exec; 

1851 I 

1852 I 

1853 exec |PROC exec (PROC (TEXT VAR, INT CONST) proc, FILE VAR f , INT CONST i) 

+ I 

1854 I 

1855 I proc (record, i) . 

1856 I 

1857 record jrecord : f. atoms (f .used. index) .line . 

1858 I 

1859 I END PROC exec; 

1860 I 

1861 pos I INT PROC pos (FILE CONST f, TEXT CONST pattern, INT CONST i) : 

1862 I 

1863 I pos (record, pattern, i) . 

1864 I 

1865 record jrecord : f. atoms (f .used. index) .line . 

1866 I 

1867 lEND PROC pos ; 

1868 I 

1869 down |PROC down (FILE VAR f, TEXT CONST pattern) : 

1870 I 

1871 I down (f, pattern, file size) 

1872 I 

1873 lENDPROC down ; 

1874 I 

1875 down |PROC down (FILE VAR f , TEXT CONST pattern, INT CONST max line) : 

1876 I 

1877 I check mode (f,mod) ; 

1878 I INT VAR pattern pos := f.col + 1 ; 

1879 I search down (f.used, f. atoms, pattern, max line, pattern pos) ; 

1880 I f.col := pattern pos 

1881 j 

1882 lENDPROC down ; 

1883 I 

1884 downety jPROC downety (FILE VAR f, TEXT CONST pattern) : 

1885 I 

1886 I downety (f, pattern, file size) 

1887 I 

1888 lENDPROC downety ; 

1889 I 
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1890 downety |PROC downety (FILE VAR f , TEXT CJONST pattern, INT CONST max line) 

1891 I 

1892 I check mode (f,mod) ; 

1893 I INT VAR pattern pos := f.col ; 

1894 I search down (f.used, f. atoms, pattern, max line, pattern pos) ; 

1895 I f.col :» pattern pos 

1896 I 

1897 lENDPROC downety ; 

1898 I 

1899 up IPROC up (FILE VAR f, TEXT CONST pattern) : 

1900 I 

1901 I up (f, pattern, file size) 

1902 I 

1903 lENDPROC up ; 

1904 j 

1905 up I PROG up (FILE VAR f , TEXT CONST pattern, INT CONST max line) : 

1906 I 

1907 I check mode (f,mod) ; 

1908 I INT VAR pattern pos := f.col - 1 ; 

1909 I search up (f.used, f. atoms, pattern, max line, pattern pos) ; 

1910 I f.col := pattern pos 

1911 I 

1912 lENDPROC up ; 

1913 I 

1914 uppety |PROC uppety (FILE VAR f , TEXT CONST pattern) : 

1915 I 

1916 I uppety (f, pattern, file size) 

1917 I 

1918 lENDPROC uppety ; 

1919 I 

1920 uppety |PROC uppety (FILE VAR f , TEXT CONST pattern, INT CONST max line) 

1921 I 

1922 I check mode (f,mod) ; 

1923 I INT VAR pattern pos := f.col ; 

1924 I search up (f.used, f. atoms, pattern, max line, pattern pos) ; 

1925 I f.col := pattern pos 

1926 I 

1927 lENDPROC uppety ; 

1928 I 

1929 I 

1930 len | INT PROC len (FILE CONST f) : 

1931 I 

1932 I length (record) . 

1933 I 

1934 record j record : f. atoms (f.used. index) .line . 

1935 I 

1936 lENDPROC len ; 

1937 I 
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1938 subtext |TEXT PROC subtext (FILE CONST f, INT CONST from, to) : 

1939 I 

1940 I subtext (record, from, to) . 

1941 I 

1942 record [record : f. atoms (f .used. index) . line . 

1943 I 

1944 lENDPROC subtext ; 

1945 1 

1946 change |PROC change (FILE VAR f , INT CONST from, to, TEXT CONST new) : 

1947 I 

1948 I check mode (f, mod) ; 

1949 I change (record, from, to, new) . 

1950 I 

1951 record | record : f. atoms (f .used. index) .line . 

1952 I 

1953 lENDPROC change ; 

1954 I 

1955 I 

1956 mark |BOOL PROC mark (FILE CONST f ) : 

1957 I 

1958 I f.mark line > 0 

1959 I 

1960 lENDPROC mark ; 

1961 I 

1962 mark I PROC mark (FILE VAR f, INT CONST line no, col) : 

1963 I 

1964 I IF line no > 0 

1965 I THEN f.mark line := lino no + f. prefix lines ; 

1966 I f.mark col := col 

1967 I ELSE f.mark line := 0 ; 

1968 I f.mark col := 0 

1969 I FI 

1970 I 

1971 lENDPROC mark ; 

1972 I 

1973 marklineno |INT PROC mark line no (FILE CONST f) : 

1974 1 

1975 1 IF f.mark line . 0 

1976 I THEN 0 

1977 I ELSE max (1, f.mark line - f. prefix lines) 

1978 I FI 

1979 I 

1980 lENDPROC mark line no ; 

1981 I 

1982 marked |INT PROC mark col (FILE CONST f) : 

1983 I 

1984 I IF f.mark line = 0 

1985 I THEN 0 

1986 I ELIF f.mark line <= f. prefix lines 

1987 I THEN 1 
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1988 I ELSE f.mark col 

1989 I ri 

1990 I 

1991 lENDPROC mark col ; 

1992 I 

1993 setmarkedrange |PROC set marked range (FILE VAR f , FRANGE VAR old range) : 

1994 I 

1995 I IF mark (f) 

1996 I THEN set range (f, mark line no (f), mark col (f), old range) 

1997 I ELSE old range := previous range of file 

1998 I FI . 

1999 I 

2000 pre viousrangeof file | previous range of file : 

2001 I FRANGE : (f. prefix lines, f. postfix lines, FALSE, FALSE) . 

2002 I 

2003 lENDPROC set marked range ; 

2004 I 

2005 I 

2006 I ( «*»»»»»«»««««««»««»'«H»«M»'W'»«««Wltl*WWWW>tWWMI»M«>»«»»«»»»WI»W«l«t««»«»»» M I»IIM«WW ) 

2007 I 

2008 I (• Autor: 
+ I P.Heyderhoff •) 

2009 I (• Stand: 11.10.83 
+ I •) 

2010 I 

2011 I BOUND LIST VAR datei; 

2012 I INT VAR sortierstelle, sortanker; 

2013 I BOOL VAR ascii sort; 

2014 I TEXT VAR median, tausch , links, rechts; 

2015 I 

2016 sort IPROC sort (TEXT CONST dateiname) : 

2017 I sort (dateiname, 1) 

2018 I END PROC sort; 

2019 I 

2020 sort I PROC sort (TEXT CONST dateiname, INT CONST sortieranfang) : 

2021 j ascii sort := TRUE ; 

2022 I sortierstelle := sortieranfang; sortiere (dateiname) 

2023 I END PROC sort; 

2024 I 

2025 lexsort |PROC lex sort (TEXT CONST dateiname) : 

2026 I lex sort (dateiname, 1) 

2027 lENDPROC lex sort ; 

2028 I 

2029 lexsort |PROC lex sort (TEXT CONST dateiname, INT CONST sortieranfamg) : 

2030 I ascii sort := FALSE ; 

2031 I sortierstelle :« sortieranfang; sortiere (dateiname) 

2032 lENDPROC lex sort ; 

2033 I 
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2034 
2035 
2036 
2037 
2038 

2039 
2040 
2041 
2042 
2043 
2044 

2045 
2046 
2047 
2048 
2049 
2050 
2051 
2052 
2053 



2054 
2055 
2056 
2057 
2058 
2059 
2060 
2061 



2062 
2063 
2064 
2065 
2066 

2067 
2068 
2069 
2070 
2071 

2072 
2073 
2074 
2075 
2076 

2077 
2078 
2079 



2081 
2082 
2083 
2064 



sort i ere 



roorganizefileifnecess 



sortfile 



quicksort 



spalte 



fangeanderseiteanundwa 



rueckepundqsodichtwlem 



vertauschediebeiden 



schiebepundqsoweitwlem 



PROC sortiere (TEXT CONST date i name) 

reorganize file if necessary ; 
sort file . 



reorganize file if necessary : 

FILE VAR f := sequential file (modify, dateinsune) 
IF segments (f) > 1 

THEN reorganize (dateiname) 
FI . 



sort file : 

f := sequential file (modify, dateiname) 
INT CONST sortende := lines (f) +3 ; 
sortanker := 1 + 3 ; 
datei := old (dateiname) ; 
quicksort ( sortanker, sortende) . 

END PROC sortiere; 



PROC quicksort ( INT CONST anfang, ende ) 
IF anfang < ende 
THEN INT VAR p,q; 

spalte (anfang, ende, p, q) ; 
quicksort (anfang, q) ; 
quicksort (p, ende) FI 
END PROC quicksort; 



PROC spalte (INT CONST anfang, ende, INT VAR p, q): 
fange an der seite an und waehle den median; 
ruecke p und q so dicht wie moeglich zusammen; 
hole ggf median in die mitte . 



fange an der seite an und waehle den median 
p := anfang; q := ende ; 
INT CONST m :: (p + q) DIV 2 ; 
median := subtext(datei m, sortierstelle) 



ruecke p und q so dicht wie moeglich zusammen : 
REP schiebe p und q so we it wie moeglich auf bzw ab; 

IF p < q THEN vertausche die beiden FI 
UNTIL p > q END REP . 



vertausche die beiden : 
tausch := datei p; date! p 
p INCR 1; q DECR 1 . 



datei q; datei q := tausch; 



schiebe p und q so weit wie moeglich auf bzw ab : 
WHILE p kann groesser werden REP p INCR 1 END REP; 
WHILE q kann kleiner werden REP q DECR 1 END REP 
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2085 


JJA.cl'lill^X UvOdC7X WOXklvII 


1 Ti If A nn fTT^rkACtO. AT* L/ATvlAn * 


2086 




1 TIP T\ y — onHA 


2087 




1 THEN links := subtext (datoi p, sortierstello) ; 


2088 




1 ir ascii sort 


2089 




1 THEN median >= links 


2090 




1 ELSE median LEXGREATEREQUAL links 


2091 




FI 


2092 




ELSE FALSE 


2093 




1 FI 


2094 






2095 


nlfAnnlf 1 aI nAT^UAi^HAn 


1 n IfAnn IflAinAi^ uatvIaii 


2096 




1 TIP n \— fi n^flnff 
1 XT H >— CLIlXCbll^ 


2097 




1 THEN rechts := subtext(datei q, sortierstelle) ; 


2098 




1 IF ascii sort 


2099 




1 THEN rechts > = median 


2100 




1 ELSE rechts LEXGREATEI^UAL median 


2101 




FI 


2102 




1 ELSE FALSE 


2103 




1 FI . 


2104 








J 4.4. 

no l6ggr nod i&n 1 nd i oin i x b 


1 hole median in die mitte 


2106 




1 IF m < q THEN vertausche m und q 


2107 




1 ELIF ra > p THEN vertausche m und p FI . 


2108 






2109 


voFb&uscnGinund^ 


1 vertausche m und q i 


2110 




1 tausch := datei m; datei m := datei q; datei q := tausch; 


+ 




1 DECR 1 . 


2111 






2112 


vertauschemundp 


1 vertausche m und p : 


2113 




1 tausch := datei m; datei m :> datei p; datei p :» tausch; 






1 INCH 1 


2114 






2115 




1 datei m d.atei<atoms (mj.i.ino . 


2116 


dateip 


1 datei p : datei. atoms (p).line . 


2117 


dateiq 


1 datei q : datei. atoms (q).line . 


2118 






2119 




|END PRCX: spalte; 


2120 






2121 




|END PACKET file handling; 
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4 
5 
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14 
15 
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23 do 
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27 
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elandointerface 



44 
45 
46 
47 
48 
49 



50 
51 
52 



doagain 



compileandexecute 



nodoagaln 



elan 



(•Autor: J. Lied 
(♦Stand: 08.11.85 



PACKET elan do interface DEFINES 
*) 

•) 
do , 

no do again : 



LET no ins = FALSE , 
no 1st = FALSE , 
no check = FALSE , 
no sermon = FALSE , 
compile line mode = 2 » 
do again mode = 4 , 
max command length = 2000 



INT VAR do again mod nr := 0 
TEXT VAR previous command := 

DATASPACE VAR ds ; 



PROC do (TEXT CONST command) : 
enable stop ; 

IF LENGTH command > max command length 

THEN errorstop (*'Kommando zu lang**) 
ELIF do again mod nr <> 0 AND command = previous command 

THEN do again 

ELSE previous command :« command ; 
compile and execute 

FI . 



do again : 

elan (do again mode, ds, do again mod nr, 
no ins, no 1st, no check, no sermon) . 



compile and execute : 

elan (compile line mode, ds, command, do again mod nr, 
no ins, no 1st, no check, no sermon) . 

ENDPROC do ; 



PROC no do again : 

do again mod nr := € 
ENDPROC no do again ; 



PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line, 
INT VAR start module number, 
BOOL CONST ins, 1st, rt check, ser) : 
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53 I EXTERNAL 256 

54 lENDPROC elan ; 

55 I 

56 lENDPACKET elan do interface ; 
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1 |(» ViKSION 4 14.05.86 •) 

2 scanner »»*»*m»»«»»»«»*m»»«# | PACKET scanner DEFINES (» Autor: J.Liedtke •] 

3 I 

4 I scan , 

5 I continue scan , 

6 I next symbol : 

7 I 

8 I 

9 |LET tetg = 1 , 

10 I bold = 2 , 

11 I number = 3 , 

12 I text = 4 , 

13 I operators 5 , 

14 I delimiter = 6 , 

15 I end of file = 7 , 

16 I within conment = 8 , 

17 I within text = 9 ; 

18 I 

19 ILET digit 0 = 48 , 

20 I digit 9 = 57 , 

21 I upper case a = 65 , 

22 I upper case z = 90 , 

23 I lower case a = 97 , 

24 I lower case z = 122; 

25 I 

26 I 

27 I TEXT VAR line := , 

28 I char := , 

29 I chars := ; 

30 I 

31 I INT VAR position := 0 » 

32 I comment depth ; 

33 I BOOL VAR continue text ; 

34 I 

35 I 

36 scan |PROC scan (TEXT CONST scan text) : 

37 I 

38 I comment depth := 0 ; 

39 I continue text := FALSE ; 

40 I continue scan (scan text) 

41 I 

42 lENDPROC scan ; 

43 I 

44 continuescan |PROC continue scan (TEXT CONST scan text) : 

45 I 

46 I line := scan text ; 

47 I position := 0 ; 

48 I nextchar 

49 I 

50 lENDPROC continue scan ; 

51 I 

52 nextsymbol |PROC next symbol (TEXT VAR symbol) : 

53 I 

54 I INT VAR type ; 

55 I next symbol (symbol, type) 

56 I 
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57 lENDPROC next symbol ; 

58 1 

59 nextsymbol |PROC next symbol (TEXT VAR symbol » INT VAR type) : 

60 I 

61 I skip blanks ; 

62 I IF is begin comment THEN process comment 

63 I ELIF comment depth > 0 THEN comment depth DECR 1 ; 
54 I process conmient 

65 I ELIF is quote OR continue text THEN process text 

66 I ELIF is lower case letter THEN process tag 

67 I ELIF is upper case letter THEN process bold 

68 I ELIF is digit THEN process number 

69 I ELIF is delimiter THEN process delimiter 

70 I ELIF is niltext THEN eof 

71 I ELSE process operator 

72 I FI . 

73 1 

74 I 

75 processcomment [process comment : 

76 I read comment ; 

77 1 IF comment depth » 0 

78 I THEN next symbol (symbol, type) 

79 I ELSE type := within comment ; 

80 1 symbol := 

81 I FI . 

82 I 

83 processtag [process tag : 

84 I type := tag ; 

85 I assemble chars (lower case a, lower case z) ; 

86 I symbol := chars ; 

87 I REP 

88 I skip blanks ; 

89 I IF is lower case letter 

90 I THEN assemble chars (lower case a, lower case z) 

91 I ELIF is digit 

92 I THEN assemble chars (digit 0, digit 9) 

93 I ELSE LEAVE process tag 

94 I FI ; 

95 I symbol CAT chars 

96 I PER ; 

97 I nextchar . 

98 I 

99 processbold j process bold : 

100 I type := bold ; 

101 1 assemble chars (upper case a, upper case z) ; 

102 I symbol := chars . 

103 I 

104 processnumber [process number : 

105 I type := number ; 

106 I assemble chars (digit 0» digit 9) ; 

107 I symbol := chars ; 

108 I IF char = AND ahead char is digit 

109 I THEN process fraction ; 

110 I IF char = "e" 

111 I THEN process exponent 

112 I FI 
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113 
114 

115 aheadcharisdiglt 

116 

117 

118 processfraction 

119 

120 

121 

122 

123 

124 processexponent 

125 

126 

127 

128 

129 

130 

131 

132 

133 

134 processtext 

135 

136 

137 

138 

139 

140 

141 

142 

143 

144 

145 

146 

147 

148 

149 

150 notendoftext 

151 

152 

153 

154 

155 

156 

157 

158 endoftextorexception 

159 

160 

161 

162 

163 

164 

165 

166 



FI . 



ahead char is digit : 
digit 0 <= code (ahead char) AND code (ahead char) <= digit 9 . 



process fraction : 
symbol CAT char ; 
nextchar ; 

assemble chars (digit 0, digit 9) ; 
symbol CAT chars . 



process exponent : 
symbol CAT char ; 
nextchar ; 

IF chaj* = OR char = 
THEN symbol CAT char ; 
nextchar 

FI ; 

assemble chars (digit 0, digit 9) ; 
symbol CAT chars . 



process text : 
type := text ; 
symbol := ; 
IF continue text 

THEN continue text := FALSE 

ELSE next char 
FI ; 

WHILE not end of text REP 
assemble chars (35, 254) ; 
symbol CAT chars ; 
IF NOT is quote 
THEN symbol CAT char ; 
nextchar 

FI 

ENDREP . 



not end of text : 
IF is niltext 

THEN continue text := TRUE ; type :« within text ; FALSE 
ELIF is quote 

THEN end of text or exception 
ELSE TRUE 
FI . 



end of text or exception : 
next char ; 
IF is quote 

THEN get quote ; TRUE 
ELIF is digit 

THEN get special char ; TRUE 
ELSE FALSE 
FI . 
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167 getquote |get quote : 

168 I symbol CAT char ; 

169 I nextchar . 

170 I 

171 getspecialchar |get special char : 

172 I assemble chars (digit 0, digit 9) ; 

173 I symbol CAT code (int (chars) ) ; 

174 I nextchar . 

175 I 

176 processdelimiter | process delimiter : 

177 I type := delimiter ; 

178 I symbol := char ; 

179 I nextchar . 

180 I 

181 processoperator | process operator : 

182 I type := operator ; 

183 I symbol := char ; 

184 I nextchar ; 

185 I IF symbol = 

186 I THEN IF char = OR char = 

187 I THEN symbol := ; 

188 I nextchar 

189 I ELSE type := delimiter 

190 I FI 

191 I ELIF is relational double char 

192 I THEN symbol CAT char ; 

193 I nextchar 

194 1 ELIF symbol = AND char = 

195 I THEN symbol := ; 

196 I next char 

197 I FI . 

198 I 

199 eof jeof : 

20© I type := end of file ; 

201 I symbol := . 

202 I 

203 islowercaseletter jis lower case letter : 

204 I lower case a <= code (char) AND code (char) <= lower case z . 

205 I 

206 isuppercase letter |is upper case letter : 

207 I upper case a <= code (char) AND code (char) <« upper case z . 

208 I 

209 isdigit |is digit : 

210 I digit 0 <» code (char) AND code (char) <» digit 9 . 

211 I 

212 isdelimiter |is delimiter : pos ( "()[].,;** , char ) > 0 . 

213 I 

214 isrelatlonaldoublechar jis relational double char : 

215 I TEXT VAR double := symbol + char ; 

216 I double = **<>" OR double = "<=" OR double = . 

217 I 
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218 isquote |is quote : char = . 

219 I 

220 isniltext |is nlltext : char = . 

221 I 

222 isbeginconunent |is begin comment : char = OR char = AND ahead char = . 

223 I 

224 lENDPROC next symbol ; 

225 I 

226 nextchar |PROC next char : 

227 I 

228 I position INCR 1 ; 

229 I char := line SUB position 

230 1 

231 lENDPROC next char ; 

232 I 

233 skipblanks | PROC skip blanks : 

234 I 

235 I position := pos (line, "*'33*'*', '•**254"", position) ; 

236 I IF position = 0 

237 I THEN position := LENGTH line + 1 

238 I FI ; 

239 I ch&T := line SUB position . 
24© I 

241 lENDPROC skip blanks ; 

242 I 

243 aheadchar |TEXT PROC ahead char : 

244 I 

245 I line SUB position+1 

246 1 

247 lENDPROC ahead char ; 

248 I 

249 assemblechars |PROC assemble chars (INT CONST low, high) : 

250 I 

251 I INT CONST begin position ; 

252 I position behind valid text ; 

253 I chars := subtext (line, begin, position-1) ; 

254 I char := line SUB position . 

255 I 

256 positionbehindvalidtex | position behind valid text : 

257 I position := pos (line, ''**32*"', code (low-1), begin) ; 

258 1 IF position = 0 

259 I THEN position := LENGTH line + 1 

261 I INT CONST higher pos := pos (line, code (high+1), ***'254*"', begin) ; 

262 I IF higher pos <> 0 AND higher pos < position 

263 I THEN position := higher pos 

264 I FI . 

265 I 

266 lENDPROC assemble chars ; 

267 I 

268 I 
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269 readcomment | PROC read comment : 

270 I 

271 I TEXT VAR last char ; 

272 I comment depth INCR 1 ; 

273 I REP 

274 I last char := char ; 

275 I nextchar ; 

276 I IF is begin comment 

277 I THEN read comment 

278 I FX ; 

279 I IF char = *"* 

280 I THEN LEAVE read comment 

281 I FI 

282 I UNTIL is end comment PER ; 

283 I comment depth SECR 1 ; 

284 I next char ; 

285 I skip blanks . 

286 I 

287 isendcomment |is end comment : 

288 I char = OR char = **)**. AND last char . . 

289 I 

290 isbegincomment jis begin comment : 

291 I char » "{"OR char « AND ahead char « . 

292 I 

293 jENDPROC read comment ; 

294 I 

295 I 

296 scan |PROC scan (FILE VAR f ) : 

297 I 

298 I getline (f, line) ; 

299 I scan (line) 

300 I 

301 lENDPROC scan ; 

302 I 

303 nextsymbol |PROC next symbol (FILE VAR f, TEXT VAR symbol) : 

304 I 

305 I INT VAR type ; 

306 I next symbol (f, symbol, type) 

307 I 

308 lENDPROC next symbol ; 

309 1 

310 I TEXT VAR scanned ; 

311 I 

312 nextsymbol |PROC next symbol (FILE VAR f, TEXT VAR symbol, INT VAR type) : 

313 I 

314 I next symbol (symbol, type) ; 

315 I WHILE type >= 7 AND NOT eof (f) REP 

316 I getline (f, line) ; 

317 I continue scan (line) ; 

318 I next symbol (scanned, type) ; 

319 I symbol CAT scanned 

320 I PER . 

321 I 

322 lENDPROC next symbol ; 
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323 I 

324 lENDPACKET scanner ; 
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1 I 

2 screendescription | PACKET screen description DEFIHES 

3 I 

4 i xsize, ysize, marksize, mark refresh line mode : 

5 I 

6 I 

7 I INT VAR xs := 80, ys := 24, ms :« 1; 

8 I 



9 xsize Iltn" PROC xsize: xs END PROC xsize; 

10 I 



11 ysize |INT PROC ysize: ys END PROC ysize; 

12 I 



13 marksize |INT PROC marksize: ms END PROC marksize; 

14 I 



15 xsize IPROC xsize (INT CONST i): xs := i END PROC xsize; 

16 I 



17 ysize |PROC ysize (INT CONST i): ys := i END PROC ysize; 

18 I 



19 marksize |PROC marksize (INT CONST i): ms := i END PROC marksize; 

20 I 

21 I 

22 I BOOL VAR line mode := FALSE; 

23 I 



24 markrefreshlinemode |BOOL PROC mark refresh line mode: 

25 I line mode 

26 I END PROC mark refresh line mode; 

27 I 



28 markrefreshlinemode |PROC mark refresh line mode (BOOL CONST b) : 

29 I line mode := b 

30 I END PROC mark refresh line mode; 

31 I 

32 I END PACKET screen description ; 
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1 I 

2 tastenverwaltung j PACKET tasten verwaltung DEFINES 
+ I #009 •) 

3 I ( M*************** ) 

4 I 

5 I lernsequenz auf taste legen, 

6 1 lernsequenz auf taste, 

7 I kommando auf taste legen, 

8 I kommando auf taste, 

9 I taste enthaelt kommando, 

10 I std tastenbelegung : 

11 I 

12 I 

13 I 

14 I LET kommandoidentifikation = "'•©♦•'' , 

15 I esc = ♦»'»27'*** , 

16 I niltext = , 

17 1 hop right left up down cr tab rubin rubout mau:k esc 

18 I = »»«i"''2'"'8''"3"*'10"''13''*'9'*''ll**''12""16"'*27*"' ; 

19 I 

20 I 

21 I ROW 256 TEXT VAR belegung; 

22 I INT VAR i; FOR i FROM 1 UPTO 256 REP belegung (i) := PER; 

23 I 

24 I std tastenbelegung; 

25 I 

26 I 

27 lernsequenzauf taste leg ...|PROC lernsequenz auf taste legen (TEXT CX)NST taste, lernsequenz) : 

28 I 

29 I be lege (belegung (code (taste) 1), taste, lernsequenz) 

30 I 

31 lENDPROC lernsequenz auf taste legen ; 

32 I 

33 belege |PROC be lege (TEXT VAR tastenpuffer, TEXT CONST taste, lernsequenz) : 

34 I tastenpuffer := lernsequenz ; 

35 I verhindere rekursives lernen . 

36 I 

37 verhindererekursivesle j verhindere rekursives lernen : 

38 I loesche alle folgen esc taste aber nicht esc esc taste ; 

39 I IF taste ist freies sonderzeichen 

40 I THEN change all (tastenpuffer, taste, niltext) 

41 I FX . 

42 I 

43 loescheallefolgenescta | loesche alle folgen esc taste aber nicht esc esc taste : 

44 I INT VAR i := pos (tastenpuffer, esc ^ taste) ; 

45 I WHILE i > 0 REP 

46 I IF ist esc esc taste 

47 I THEN i INCR 1 

48 I ELSE change (tastenpuffer, i, i+1, niltext) 

49 I FI ; 

50 I i := pos (tastenpuffer, esc + taste, i) 

51 I PER . 
52 
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53 istescesctaste |ist esc esc taste : 

54 I ( tastenpuf f er SUB i-1) = esc AND ( tastenpuf f er SUB i-2) <> esc . 

55 I 

56 tasteistfreiessonderze | taste ist freies sonderzelchen : 

57 I taste < "*'32"*' AND 

58 I pos (hop right left up down cr tab rubin rubout mark esc, taste) 
+ I 0 . 

59 I 

60 I END PROC be lege ; 

61 I 

62 I 

63 lernsequenzauf taste |TEXT PROC lernsequenz auf taste (TEXT COUST taste) : 

64 I IF taste enthaelt kommando (taste) 

65 j THEN 

66 I ELSE belegung (code (taste) -»- 1) 

67 I FI 

68 I END PROC lernsequenz auf taste; 

69 I 

70 I 

71 kommandoauftastelegen jPRCXJ kommando auf taste legen (TEXT CONST taste, kommando) : 

72 I 

73 I belegung (code (taste) •«■ 1) := konmandoldentlf ikation; 

74 I belegung (code (taste) + 1) CAT kommando 

75 I 

76 I END PROC kommando auf taste legen; 

77 I 

78 I 

79 kommandoauf taste |TEXT PR(X3 kommando auf taste (TEXT CONST taste) : 

80 I IF taste enthaelt kommando (taste) 

81 I THEN subtext (belegung (code (taste) +1), 2) 

82 I ELSE 

83 I FI 

84 I END PROC kommando auf taste; 

85 I 

86 I 

87 tasteenthaeltkommando |BOOL PROC taste enthaelt kommando (TEXT CONST taste) : 

88 I (belegung (code (taste) + 1) SUB 1) = kommando identif ikation 
69 I END PROC taste enthaelt kommando; 

90 I 

91 I 

92 stdtastenbelegung |PROC std tastenbelegung: 

93 I lernsequenz auf taste legen ("(", ""91''**); 

94 I lernsequenz auf taste legen (**)**, *'"93*'**); 

95 I lernsequenz auf taste legen (**<**, *'**123''**) ; 

96 I lernsequenz auf Uste legen (">**, *'**125*"'); 

97 I lernsequenz auf taste legen (**A**, ****214''**) ; 

98 I lernsequenz auf taste legen ("0**, **'*215****) ; 

99 I lernsequenz auf taste legen (**U**, "**216*'*'); 

100 I lernsequenz auf taste legen (*'a*', *'*'217**'*) ; 

101 I lernsequenz auf taste legen (*'o'*, "''218*"*); 

102 I lernsequenz auf taste legen (*'u*', ""219****); 
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103 I lernsequenz auf taste legen Ck**, ^**22Q*"*); 

104 I lernsequenz auf taste legen (**-**, ""221***' ) ; 

105 I lernsequenz auf taste legen *'**222****) ; 

106 I lernsequenz auf taste legen (" ""223'*''); 

107 I lernsequenz auf taste legen ("B", "''251'"*); 

108 I lernsequenz auf taste legen ("s", ""251""); 

109 I END PROC std tastenbelegung; 

110 I 

111 I 

112 I END PACKET tasten verwaltung; 
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editor paket 



1 edltorpeiket 

2 



5 
+ 
6 
+ 
7 
8 
9 
10 
11 
12 
13 
14 
15 
16 
17 
18 
19 
20 
21 
22 
23 
24 
25 
26 
27 
28 
29 
30 
31 
32 
33 
34 
35 
36 
37 
38 
39 
40 
41 
42 
43 
44 
45 
46 
47 
48 
•»• 
49 
50 
51 
52 
53 
54 
55 



PACKET editor paket DEFINES 
123 *) 

-bk- *) 



-sh- 



LET 



LET 



edit, editget, 

-wk- « ) 
quit, quit last, 

-jl- •) 
push, type, 
word wrap, margin, 
write permission, 
set busy indicator 
two bytes, 
is kanji esc, 
within kanJi, 
rubin mode, 
is editget, 
editget command, 
getchar, 
getcharety, 
is incharety, 
get window, 
get editcursor, 
get editline, 
put editline, 
aktueller editor 
groesster editor 
open editor, 
editfile. 



hop 

up char 
clear eol 
piep 

down char 

rubout 

mark key 

inscr 

backer 

dach 



no output ■ 0, 

out feldrest = 2, 
clear feldrest = 4; 



• EDITOR 

• 19.07.85 

• 10.09.85 
» 25.04.86 

• 10.06.86 
« 04.06.86 





nichts neu, 






satznr neu. 






ueberschrift neu. 




zeile neu. 






abschnitt neu. 






bildabschnitt 


neu. 




blld neu, 






alles neu. 






satznr zelgen. 






ueberschrift zeigen, 




bild zeigen: 






right 






clear eop 


4 , 




cursor pos 






left 






rubin 


= ""11"" 




cr 


. ""13"" 




abscr 






dezimal 


= "-19"" 




esc 


3 ""27"" 


****94*'** 


blank 





out zeichen 
out feld 



LET FELDSTATUS « STRUCT (INT stelle, alte stelle, rand, limit, 

anfang, narke, laenge, verschoben, 

BOOL einfuegen, fliesstext, write 
access, 

TEXT tabulator); 

FELDSTATUS VAR foldstatus; 

TEXT VAR begin mark :« ""15"". 

end mark ""14""; 

TEXT VAR separator "", komraando ;. "", audit :» "", zeichen "" 
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56 I satzrest := raerksatz :x alter editsatz := 

57 1 

58 I INT VAR kommando zeiger := 1, umbruchs telle, umbruch verschoben, 

59 I zeile, spalte, output mode := no output, postblanks := 9, 
6® I min schreibpos, max schreibpos, epos, absatz ausgleich; 

61 I 

62 I BOOL VAR lernmodus := FALSE, separator eingestellt := FALSE, 

63 I invertierte deurstellung :» FALSE, absatzmarke steht, 

64 I cursor diff := FALSE, editget modus := FALSE, 

65 I two byte mode := FALSE, std fliesstext := TRUE, 

66 I editget kommando darf ausgefuhrt werden := TRUE;. 

67 I 

68 schirmbreite | schirmbreite : x size - 1 . 

69 schirmhoehe jschirrahoehe : y size . 

70 maxbreite |maxbreite : schirmbreite - 2 . 

71 maxlaenge |maxlaenge : schirmhoehe - 1 . 

72 marklength jmarklength : mark size .; 

73 I 

74 I initialisiere editor; 

75 I 

76 j .initialisiere editor : 

77 I anfang :» 1; zeile := 0; verschoben := 0; tabulator := , 

78 I einfuegen := FALSE; fliesstext := TRUE; zeileneinfuegen := FALSE 

79 I marke := 0; bildmarke := 0; feldmarke := 0.; 

80 I 

81 editgetcommand |PROC editget command (BOOL CONST schalter) : 

82 I editget konmiando darf ausgefuhrt werden := schalter 

83 lENDPROC editget command ; 

84 I 

86 I 

87 editget |PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge, 

88 I TEXT CONST sep, res, TEXT VAR exit char) : 

89 I IF editlaenge < 1 THEN errorstop ("Fenster zu klein**) FI; 

90 I separator := ""IS*"*; separator CAT sep; 

91 I separator eingestellt := TRUE; 

92 1 TEXT VAR reservierte editget tasten "'•^"''ig*'" ; 

93 I reservierte editget tasten CAT res ; 

94 I disable stop; 

95 I absatz ausgleich := 0; exit char ;= **"; get cursor; 

96 I FELDSTATUS CONST alter feldstatus := feldstatus; 

97 I feldstatus := FELDSTATUS : (1, 1, spalte - 1, editlimit, 

98 I 1, 0, editlaenge, 0, 

99 I FALSE, FALSE, TRUE, *•"); 

100 I konstanten neu berechnen; 

101 I output mode :« out feld; 

102 I feld editieren; 

103 I zeile verlassen; 

104 I feldstatus :« alter feldstatus; 

105 I konstanten neu berechnen; 

106 I separator :=**"; 

107 I separator eingestellt := FALSE . 
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108 

109 feldeditieren 

110 
111 
112 
113 
114 
115 
116 
117 
118 
119 
120 
121 
122 
123 
124 
125 
126 
+ 

127 
128 
129 
130 
+ 

131 
132 
133 
134 
135 
136 
137 
138 
139 
140 
141 
142 
143 
144 
145 
146 
147 
148 
149 

150 zelchenistkelnesckonsna 

+ 

151 
152 

153 zeileverlassen 

154 

155 

156 

157 

158 

159 zeichenistseparator 
160 



feld editioren : 
REP 

feldeditor (editsatz, resorvierte editget tasten); 
IF is error 

THEN kommando zeiger := 1; koramando :« LEAVE feld editieren 
FI ; 

TEXT VAR t, zeichen; getcheu* (zeichen); 
IF zeichen ist separator 

THEN exit char := zeichen; LEAVE feld editieren 
ELIF zeichen = hop 

THEN feldout (editsatz, stelle); getchar (zeichen) 
ELIF zeichen = mark key 
THEN output mode := out feld 
ELIF zeichen = abscr 

THEN exit char := cr; LEAVE feld editieren 
ELIF zeichen = esc 

THEN getchar (zeichen); auf exit pruefen; 
IF zeichen = rubout 

(*sh«) 
THEN IF marke > 0 

THEN merksatz := subtext ( editsatz « marke, stelle - 1); 
change (editsatz, marke, stelle - 1, ****); 
stelle := marke; marke 0; konstanten neu 
berechnen 

FI 

ELIF zeichen = rubin 

THEN t := subtext (editsatz, 1, stelle - 1); 
t CAT merksatz; 

satzrest := subtext (editsatz, stelle); 
t CAT satzrest; 
stelle INCR LENGTH merksatz; 
merksatz := ****; editsatz := t 
ELIF editget kommando darf ausgefuhrt werden 
CAND 

zeichen ist kein esc kommando 
CAND 

kommando auf taste (zeichen) <> 
THEN editget kommando ausfuehren 
FI ; 

output mode : > out feld 

FI 
PER . 



zeichen ist kein esc kommando : 
(♦wk«) 

pos (hop + left + right, zeichen) « 0 . 



zeile verlassen : 

IF marke > 0 OR verschoben <> 0 

THEN stelle DECR verschoben; verschoben :* 0; feldout (editsatz, 8); 
ELSE cursor (rand + 1 + min (LENGTH editsatz, editlaenge), zeile) i 

FI . \ 



zeichen ist separator : pos (separator, zeichen) > 6 . | 

I 
1 



21/3 



editor paket 



21/3 



Zello ELAN EUMEL 1.8 ♦«»♦♦ 10.11.86 •••• editor paket 



161 aufexitpruefen |auf exit pruefen : 

162 I ir pos (res, zeichen) > 0 

163 I THEN exit char := esc -»■ zeichen; LEAVE feld editieren 

164 I n . 

165 I 

166 edltgetkonunandoausfueh jeditget kommando ausfuehren : 

167 I editget zustaende sichern ; 

166 I do (kommando auf taste (zeichen)) ; 

169 I alte editget zustaende wieder herstellen ; 

170 I IF stelle < marke THEN stelle := marke FI; 

171 I konstanten neu berechnen . 

172 I 

173 editgetzustaendesicher jeditget zustaende sichern : 
+ I (•wk*) 

174 I BOOL VAR alter editget modus := editget modus; 

175 j FELDSTATUS VAR feldstatus vor do kommando := feldstatus ; 

176 I INT VAR zeile vor do kommando := zelle ; 

177 I TEXT VAR separator vor do kommando := separator ; 

176 I BOOL VAR separator eingestellt vor do koinnando :> separator 

+ I eingestellt ; 

179 I editget modus := TRUE ; 

160 I alter editsatz := editsatz . 

161 I 

162 alteeditgetzustaendewi jalte editget zustaende wieder herstellen : 

163 I editget modus := alter editget modus ; 

164 I editsatz := alter editsatz; 

165 I feldstatus := feldstatus vor do kommando ; 

166 I zeile := zeile vor do kommando ; 

167 I separator := separator vor do kommando ; 

166 I separator eingestellt := separator eingestellt vor do kommando . 

169 I 

190 I END PROC editget; 

191 I 

192 editget |PROC editget (TEXT VAR editsatz, INT CX)NST edltlimit, TEXT VAR exit 

♦ I char) : 

193 I editget (editsatz, editlimit, x size - x cursor, exit chJ 

194 |END PROC editget; (• 05.07.84 
+ I -bk- •) 

195 I 

196 editget |PROC editget (TEXT VAR editsatz, TEXT CONST sep, res, TEXT VAR exit 

■^ I char) : 

197 I editget (editsatz, max text length, x size - x cursor, sep, res, 
+ I exit char) 

198 |END PROC editget; (• 05.07.84 
+ I -bk- *) 

199 I 

200 editget |PROC editget (TEXT VAR editsatz) : 

201 I TEXT VAR exit char; (• 05.07.8/ 
+ I -bk- •) 

202 I editget (editsatz, max text length, x size - x cursor, 
+ I exit char) 

203 I END PROC editget; 

204 I 
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205 editget |PROC editget (TEXT VAR editsatz, INT CJONST editlimit, editlaenge) : 

206 I TEXT VAR exit char; 

207 I editget (editsatz, editlimit, editUenge, exit char) 

208 lENDPROC editget; 

209 I 

21© j ( »«*«»»*«♦#»»»»»♦«**«««»♦♦»»#»#» feldeditcr 

211 I 

212 I TEXT VAR reservierte feldeditcr tasten ; 
+ I (•j» 

213 I 

214 feldeditcr |PROC feldeditcr (TEXT VAR satz, TEXT CONST res) : 

215 I enable stop; 

216 I reservierte feldeditcr tasten := ''"^♦•"g^^s**'* ; 

217 I reservierte feldeditcr tasten CAT res; 

218 I absatzmarke steht := (satz SUB LENGTH satz) = blank; 

219 I alte stelle merken; 

22© I cursor diff bestimmen und ggf ausgleichen; 

221 I feld editieren; 

222 I absatzmarke update n . 

223 I 

224 altestellemerken jalte stelle merken : alte stelle :> stelle . 

225 I 

226 curscrdiffbestimmenund | cursor diff bestimmen und ggf ausgleichen : 

227 I IF cursor diff 

228 I THEN stelle INCH 1; cursor diff := FALSE 

229 i FI ; 

23© I IF stelle auf zweitem halbzeichen 

231 I THEN stelle DECR 1; cursor diff TRUE 

232 I FI . 

233 I 

234 feldeditieren jfeld editieren : 

235 I REP 

236 I feld optisch aufbereiten; 

237 j korranando annehmen und ausfuehren 

238 I PER . 

239 I 

240 absatzmarkeupdaten | absatzmarke updaten : 

241 j IF absatzmarke soil stehen 

242 I THEN IF NOT absatzmarke steht THEN absatzmarke schreiben (TRUE) FI 

243 I ELSE IF absatzmarke steht THEN absatzmarke schreiben (FALSE) f 

244 I FI . 

245 I 

246 absatzmeirkesollstehen j absatzmarke soli stehen : (satz SUB LENGTH satz) = blank . 

247 I 

248 feldoptischaufbereiten |feld optisch aufbereiten : 

249 I stelle korrigieren; 

250 I verschieben wenn erforderlich; 

251 I randausgleich fuer doppelzeichen; 

252 I output mode behandeln; 

253 I ausgabe verhindern . 

254 i 
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255 randausglelchfuerdoppe | randausgleich fuer doppelzeichen : 

256 i ir stelle = max schreibpos CAND stelle auf erstem halbzelchen 

257 I THEN verschiebe (1) 

258 I ri . 

259 I 

260 stellokorrlgieren [stelle korrigieren : 

261 I IF stelle auf zweitem halbzelchen THEN stelle DECR 1 FI . 

262 I 

263 stelleauferstemhalbzei | stelle auf erstem halbzelchen : within kanjl (satz, stelle 1) . 

264 I 

265 stelleaufzweltemhalbze | stelle auf zweitem halbzelchen : within kanjl (satz, stelle) . 

266 i 

267 outputfflodebehandeln | output mode behandeln : 

268 I SELECT output mode OF 

269 j CASE no output : im markiermode markierung anpassen 

270 I CASE out zelchen : zelchen ausgeben; LEAVE output mode 
■*■ I behandeln 

271 I CASE out feldrest : feldrest neu schreiben 

272 I CASE out feld : feldout (satz, stelle) 

273 I CASE clear feldrest : feldrest loeschen 

274 I END SELECT; 

275 I schrelbmarke posltlonleren (stelle) . 

276 I 

277 ausgabeverhindern |ausgabe verhindern : output mode := no output . 

278 I 

279 innarkiermoderoeirklerun jlm markiermode marklerung anpassen : 

260 I IF marklert THEN marklerung anpassen FI . 

281 I 

282 markierunganpassen | marklerung anpassen : 

283 I IF stelle > alte stelle 

284 I THQJ marklerung verlaengern 

285 I ELIF stelle < alte stelle 

286 I THEN marklerung verkuerzen 

287 I FI . 

288 I 

289 marklerungverlaengem j marklerung verlaengern : 

290 I Invers out (satz, alte stelle, stelle, ****, end mark) . 

291 I 

292 markierungverkuerzen j marklerung verkuerzen : 

293 I invers out (satz, stelle, alte stelle, end mark, "") . 

294 I 

295 zelchenausgeben | zelchen ausgeben : 

296 I IF NOT marklert 

297 I THEN out (zelchen) 

298 I ELIF mark refresh line mode 

299 I THEN feldout (satz, stelle); schrelbmarke posltlonleren (stelle) 

300 I ELSE out (begin mark); markleft; out (zelchen); out (end mark); 

I markleft 

301 1 FI . 

302 I 
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303 narkleft |markleft : 

304 I marklength TIMESOUT left . 

305 I 

306 feldrestneuschreiben {feldrest neu schreiben : 

307 I IF NOT markiert 

308 I THEN feldrest unmarkiert neu schreiben 

309 I ELSE feldrest markiert neu schreiben 

310 I FI ; 

311 I WHILE postblanks > 0 CAND x cursor <« rand + laenge REP 

312 I out (blank); postblanks DECK 1 

313 1 PER ; postblanks := 0 . 

314 I 

315 feldrestunmarkiertneus (feldrest unmarkiert neu schreiben : 

316 I schreibmarke positionieren (alte stelle); 

317 I out subtext mit randbehandlung (satz, alte stelle, stelle am enda) 
+ I 

318 I 

319 feldrestmarkiertneusch j feldrest markiert neu schreiben : 

320 I markierung verlaengern; out subtext mit randbehandlung 

321 I (satz, stelle, stelle ajn ende - 2 • 

I marklength) . 

322 I 

323 kommandoannehmenundaus |kommando annehmen und ausfuehren : 

324 I kommando annehmen; kommando ausfuehren . 

325 I 

326 kommandoannehmen | kommando annehmen : 

327 I getchar (zeichen); kommando zurueckweisen falls noetig . 

328 I 

329 kommandozurueckweisonf | kommando zurueckweisen falls noetig : 

330 j IF NOT write access CAND zeichen ist druckbar 

331 I THEN benutzer warnen; kommando ignorieren 

332 I FI . 

333 I 

334 benutzerwarnen | benutzer warnen : out (piep) . 

335 I 

336 konmiando ignorieren | kommando ignorieren : 

337 I zeichen ****; LEAVE kommando annehmen und ausfuehren . 

338 I 

339 kommandoausfuehren | kommando ausfuehren : 

340 I neue satzlaenge bestimmen; 

341 I alte stelle merken; 

342 I IF zeichen ist separator 

343 I THEN feldeditor verlassen 

344 I ELIF zeichen ist druckbar 

345 I THEN fortschreiben 

346 I ELSE funktionstasten behandeln 

347 I FI . 

348 I 

349 neuesatzlaengebestimme jneue satzlaenge bestimmen : INT VAR satzlaenge :^ LENGTH satz . 

350 I 
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351 feldeditorverlassen |feldeditor verlassen : 

352 I IF NOT absatzmarke steht THEN blanks abschneiden FI; 
+ I (•sh*) 

353 I push (zeichen); LEAVE feld editieren . 

354 I 

355 blanksabschneiden | blanks abschneiden : 

356 I INT VAR letzte non blank pos := satzlaenge; 

357 I WHILE letzte non blank pos > 0 CAND (satz SUB letzte non blank 
+ \ pos) = blank REP 

358 I letzte non blank pos DECR 1 

359 I PER; satz := subtext (satz, 1, letzte non blank pos) . 

360 I 

361 zeichenistdruckbar j zeichen ist druckbar : zeichen >= blank . 

362 I 

363 zeichenistseparator | zeichen ist separator : 

364 I separator eingestellt CAND pos (separator, zeichen) > 0 . 

365 I 

366 fortschreiben | fortschreiben : 

367 I zeichen in satz eintragen; 

368 I IF is kanji esc (zeichen) THEN kanjl zeichen schreiben FI; 

369 I bei erreichen von limit ueberlauf behandeln . 

370 I 

371 zeicheninsatzeintragen {zeichen in satz eintragen : 

372 I IF hinter dem satz 

373 I THEN satz mit leerzeichen auffuellen und zeichen anfuegen 

374 I ELIF einfuegen 

375 I THEN zeichen vor eiktueller position einfuegen 

376 I ELSE altes zeichen ersetzen 

377 I FI . 

378 I 

379 hlnterdemsatz j hinter dem satz : stelle > satzlaenge . 

380 I 

381 satzraitleerzeichenauff jsatz mit leerzeichen auffuellen und zeichen anfuegen : 

382 I satz AUFFUELLENMIT blank; 

383 I zeichen anfuegen; 

384 I output mode := out zeichen . 

385 I 

386 zeichenanfuegen j zeichen anfuegen : satz CAT zeichen; neue satzleienge bestimnen . 

387 zeichenignorieren [zeichen ignorieren : benutzer warnen; LEAVE kommando ausfuehren . 

388 I 

389 zeichenvoraktuellerpos j zeichen vor aktueller position einfuegen : 

390 I Insert char (satz, zeichen, stelle); 

391 I neue satzlaenge bestimmen; 

392 I output mode := out feldrest . 

393 I 

394 alteszeichenersetzen j altes zeichen ersetzen : 

395 I replace (satz, stelle, zeichen); 

396 I IF stelle auf erstem halbzelchen 

397 I THEN output mode :« out feldrest; replace (satz, stelle + 1, blank) 

398 I ELSE output mode := out zeichen 

399 I FI . 
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400 I 

401 kanjizelchenschreiben jkanoi zelchen schreiben : 

402 I alte stelle merken; 

403 I stelle INCR 1; getchar (zeichen); 

404 I IF zeichen < *'*'64"" THEN zeichen ""64"" PI; 

405 I IF hinter dem satz 

406 I THEN zeichen anfuegen 

407 I ELIF einfuegen 

408 I THEN zeichen vor aktueller position einfuegen 

409 I ELSE replace (satz, stelle, zeichen) 

410 I FT ; 

411 I output mode := out feldrest . 

412 I 

413 beierreichenvonlimitue jbei erreichen von limit ueberlauf behandeln : 
+ I (•sh*) 

414 I IF satzlaenge kritisch 

415 I THEN in naechste zeile falls moeglich 

416 I ELSE stelle INCR 1 

417 I FI . 

418 I 

419 satzlaengekritisch | satzlaenge kritisch : 

420 j IF stelle satzlaenge 

421 I THEN satzlaenge = limit 

422 I ELSE satzl€ienge « limit * 1 

423 I FI . 

424 I 

425 innaechstezeilefallsmo |in naechste zeile falls moeglich : 

426 1 IF fliesstext AND umbruch moeglich OR NOT fliesstext AND stelle 
•»■ I >3 satzlaenge 

427 I THEN in naechste zeile 

428 I ELSE stelle INCR 1 

429 I FI . 

430 I 

431 umbruchmoeglich [umbruch moeglich : 

432 I INT CONST st := stelle; stelle := limit; 

433 I INT CONST Itzt wortanf := letzter wortanfang (satz); 

434 I stelle ;= st; einrueckposition (satz) < Itzt wortanf . 

435 I 

436 innaochstezeile |in naechste zeile : 

437 I IF fliesstext 

438 1 THEN ueberlauf und oder umbruch 

439 I ELSE ueberlauf ohne umbruch 

440 I FI . 

441 I 

442 ueberlauf undoderumbruc j ueberlauf und oder umbruch : 

443 I INT VAR umbruchpos :« 1; 

444 I umbruchposition bestimmen; 

445 I loeschposition bestinsnen; 

446 I IF stelle = satzlaenge 

447 I THEN ueberlauf mit oder ohne umbruch 

448 I ELSE umbruch mit oder ohne ueberlauf 

449 I FI . 

450 I 
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451 umbruchpositionbestimm |umbruchposition bestimraen : 

452 I umbruchstelle := stelle; | 

453 I stelle := satzlaenge; 

454 I umbruchpos := max (umbruchpos, letzter wortanfang (satz)); 

455 I stelle umbruchstelle . 

456 I 

457 loeschpositionbestimme | loeschposition bestimmen : 

458 I INT VAR loeschpos := umbruchpos; 

459 I WHILE davor noch blank REP loeschpos DECR 1 PER . 
46® I 

461 davornochblank | davor noch blank : 

462 I loeschpos > ganz links CAND (satz SUB (loeschpos - 1)) = blank . 

463 I 

464 ganzlinks |ganz links : max (1, marke) . 

465 I I 

466 ueberlaufmitoderohneum |ueberlauf mit oder ohne umbruch : 

467 I IF zelchen ^ blank OR loeschpos > ganz links 

468 I THEN stelle := 1; ueberlauf ohne umbruch 

469 I ELSE ueberlauf mit umbruch 

470 I FI . 

471 I 

472 ueberlaufohneumbruch [ueberlauf ohne umbruch : push (cr) . 

473 I 

474 ueberlaufmitumbruch j ueberlauf mit umbruch : 

475 I ausgabe verhindern; 

476 I umbruchkommando aufbereiten; 

477 I auf loeschposition positionieren . 

478 I 

479 umbruchkommandoaufbere | umbruchkommando aufbereiten : 

480 I zeichen := hop + rubout + inscr; 

481 I satzrest := subtext (satz, umbruchpos); 

482 I zeichen CAT satzrest; 

483 I IF stelle ist im umgebrochenen tell 

484 I THEN insert char (zeichen, backer, max (stelle - umbruchpos 1, 
+ I 0) + 4); 

485 I zeichen CAT backer 

486 I FI ; 

487 I push (zeichen) . 

488 1 

489 stelleistimumgebrochen | stelle ist im umgebrochenen teil : stelle >= loeschpos . 

490 I 

491 aufloeschpositionposit jauf loeschposition positionieren : stelle ;» loeschpos . 

492 I 

493 umbruchmitoderohneuebe | umbruch mit oder ohne ueberlauf : 

494 I umbruchposition anpassen; 

495 I IF stelle ist im umgebrochenen teil 

496 I THEN umbruch mit ueberlauf 

497 I ELSE umbruch ohne ueberlauf 

498 1 FI . 

499 I 

21/10 editor paket 21/10 



Zeile ELAN EUMEL 1.8 10.11.86 editor paket 



500 umbruchpositionanpasse 

501 

502 

503 

504 

505 

506 

507 neueloeschpositionbest 
508 
509 
+ 

510 

511 stellenochnichterreich 
512 

513 umbruchmitueberlauf 
514 

515 umbruchohneueberlauf 

516 

517 

518 

519 

520 

521 

522 

523 

524 

525 

526 funktionstastenbehande 
527 
528 
529 
530 
531 
532 
533 
534 
535 
536 
537 
+ 

536 
539 
540 
541 
542 
543 

544 konunandos 

545 

546 

547 

548 

549 

550 

551 

552 

553 



umbruchposition anpassen : 
IF zeichen = blank 
THEN umbruchpos := stelle + 1; 
umbruchposition bestimmen; 
neue loeschposition bestimmen 

FI . 



neue loeschposition bestimmen : 
loeschpos umbruchpos; 

WHILE davor noch blank AND stelle noch nicht erreicht REP 
loeschpos DECR 1 PER . 



stelle noch nicht erreicht : loeschpos > stelle + 1 . 



umbruch mit ueberlauf : ueberlauf mit umbruch . 



umbruch ohne ueberlauf : 
zeichen := inscr; 

satzrest := subtext (satz, umbruchpos); 
zeichen CAT satzrest; 
zeichen CAT up char + backer; 

umbruchstelle INCR 1; umbruch verschoben := verschoben; 

satz := subtext (satz, 1, loeschpos - 1); 

schreibmarke positionieren (loeschpos); feldrest loeschen; 

output mode := out feldrest; 

push (zeichen) . 



funktionstasten behandeln : 



SELECT 


pos (komraandos, zeichen) OF 


CASE 


c hop 


hop kommandos behandeln 


CASE 


c esc 


esc kommandos behandeln 


CASE 


c right 


nach rechts oder ueberlauf 


CASE 


c left 


wenn moeglich ein schritt nach links 


CASE 


c tab 


zur naechsten tabulator position 


CASE 


c dezimal 


dezimalen schreiben 


CASE 


c rubin 


einfuegen umschalten 


CASE 


c rubout 


ein zeichen loeschen 


CASE 


c abscr, c 


inscr, c down : feldeditor verlassen 


CASE 


c up 


eine zeile nach oben 




(•sh*) 




CASE 


c cr 


ggf absatz erzeugen 


CASE 


c mark 


markieren umschalten 


CASE 


c backer 


zurueck zur umbruchstelle 


OTHERWISE 


sondertaste beharxleln 



END SELECT . 



kommandos : 



c 


hop 


= 1, 


c right 


» 2, 


c 


up 


= 3, 


c left 


= 4, 


c 


tab 


= 5, 


c down 


= 6, 


c 


rubin 


= 7, 


c rubout 


= 8. 


c 


cr 


= 9, 


c mark 


= le. 


c 


abscr 


= 11, 


e inscr 


= 12, 


c 


dezimal 


= 13, 


c esc 


= 14, 


c 


backer 


= 15; 







21/11 



editor paket 



21/11 



Zeile ELAN 



EUMEL 1.8 »»•• 10.11.86 •••• editor paket 



554 I »»«j^»»»»2***'3****8*"*9****10'*"ll'**'12''*'13*"'16*'**17*'**18''*'19'**'27***'20'"' . 

555 I 

556 deziinalenschreiben jdezimalen schrelben : IF write access THEN dezimaleditor (satz) FI . 

557 I 

558 zurueckzurumbruchstell jzurueck zur umbruchstelle : 

559 I IF umbruch stelle > 0 THEN stelle umbruch stelle FI; 

560 I IF verschoben <> umbruch verschoben 

561 I THEN verschoben := umbruch verschoben; output mode := out feld 

562 I FI . 

563 I 

564 hopkommandosbehandeln jhop kommandos behandeln : 

565 I TEXT VAR zweites zeichen; getchar (zweites zeichen); 

566 I zeichen CAT zweites zeichen; 

567 I SELECT pos (hop kommandos, zweites zeichen) OF 

568 I CASE h hop : nach links oben 

569 I CASE h right : nach rechts blaettern 

570 I CASE h left : nach links blaettern 

571 I CASE h tab : tab position definieren oder loeschen 

572 I CASE h rubin : zeile splitten 

573 I CASE h rubout : loeschen oder rekombinleren 

574 I CASE h cr, h up, h down : feldeditor verlassen 

575 I OTHERWISE : zeichen ignorieren 

576 I END SELECT . 

577 I 

578 hopkonnandos jhop kommandos : 

579 I LET h hop =1, h right = 2. 

580 I h up = 3, h left = 4, 

581 I h tab = 5, h down = 6, 

582 I h rubin « 7, h rubout » 8, 

583 I h cr =9; 

584 I 

585 I ♦»»»i»»*»2'*'*3''"8***'9*'*'10*'**ll*'*'12*'**13'**' . 

586 I 

587 nachlinksoben jnach links oben : 

588 I stelle := max (marke, anfang) + verschoben; feldeditor verlassen 

589 I 

590 nachrechtsblaettern jnach rechts blaettern : 

591 j INT CONST rechter rand :* stelle am ende - markierausgleich; 

592 I IF stelle ist am rechten rand 

593 I THEN stelle INCH laenge - 2 » markierausgleich -»- ausgleich fuer 
+ I doppelzeichen 

594 I ELSE stelle := rechter rand 

595 I FI ; 

596 I IF satzlaenge <= limit THEN stelle := min (stelle, limit) FI; 

597 I alte einrueckposition mitziehen . 

598 I 

599 stelleistanrechtenrand | stelle ist am rechten rand : 

600 I stelle auf erstem halbzeichen CAND stelle « rechter rand - 1 

601 I COR stelle = rechter rand . 

602 I 

603 ausgleichfuerdoppelzei j ausgleich fuer doppelzeichen : stelle - rechter rand . 

604 I 

21/12 editor paket 21/12 



Zeile •••• ELAN EUMEL 1.8 10.11.86 editor paket 



605 nachlinksblaettern |nach links blaettern : 

606 j INT CONST linker rand := stelle am anfang; 

607 I IF stelle = linker rand 

608 I THEN stelle DECR laenge - 2 » markierausgleich 

609 I ELSE stelle := linker rand 

610 i n ; 

611 I stelle := max (ganz links, stelle); 

612 I alte einrueckposition mitziehen . 

613 I 

614 tabpositiondefiniereno |tab position definieren oder loeschen : 

615 I IF stelle > LENGTH tabulator 

616 I THEN tabulator AUFFUELLENMIT right; tabulator CAT dach 

617 I ELSE replace (tabulator, stelle, neues tab zeichen) 

618 I FI ; 

619 I feldedltor verlassen . 

620 I 

621 neuostabzeichen | neues tab zeichen : 

622 j IF (tabulator SUB stelle) - right THEN dach ELSE right FI . 

623 I 

624 zollesplitten j zeile splitten : 

625 I IF write access THEN feldeditor verlassen ELSE zeichen ignorlerei] 

+ I FI . 

626 I 

627 loeschenoderrekofflbinie | loeschen oder rekombinieren : 

628 I IF NOT write access 

629 I THEN zeichen ignorieren 

630 I ELIF hinter dem satz 

631 I THEN zeilen rekombinieren 

632 I ELIF auf erstem zeichen 

633 I THEN ganze zeile loeschen 

634 I ELSE zeilenrest loeschen 

635 j FI . 

636 I 

637 zeilenrekorabinieren | zeilen rekombinieren : feldeditor verlassen . 

638 auferstemzeichen |auf erstem zeichen : stelle = 1 . 

639 ganzezeileloeschen | ganze zeile loeschen : satz := ****; feldeditor verlassen . 

640 I 

641 zeilenrestloeschen | zeilenrest loeschen : 

642 I change (satz, stelle, satzlaenge, *"*); 

643 I output mode := clear feldrest . 

644 I 

645 esckomroandosbehandeln jesc kommandos behandeln : 

646 I getchar (zweites zeichen); 

647 I zeichen CAT zweites zeichen; 

648 I auf exit pruefen; 

649 i SELECT pos (esc kommandos, zweites zeichen) OF 

650 I CASE e hop : lernmodus umschalten 

651 I CASE e right : zum naechsten wort 

652 I CASE e left : zum vorigen wort 

653 I OTHERWISE : belegte taste ausfuehren 

654 I END SELECT . 

655 I 

21/13 editor paket 21/13 



Zeile ELAN EUMEL 1.8 «•»• 10.11.86 »♦** editor p€Lket 



656 aufexitpruefen |auf exit pruefen : 

657 I IF pos (res, zweites zeichen) > 0 THEN feldeditor verlassen PI . 

658 I 

659 esckommandos |esc kommandos : 

660 I LET e hop = 1, 

661 I e right = 2, 

662 I e left = 3; 

663 I 

664 I "•'i*'*'2*"*8''" . 

665 I 

666 lernmodusumschalten |lernniodus umschalten : 

667 I IF lernmodus THEN lernmodus ausschalten ELSE lernmodus einschalten 
+ I FI; 

668 I feldeditor verlassen . 

669 I 

67© lernmodusausschalten | lernmodus ausschalten : 

671 I lernmodus := FALSE; 

672 I belegbare taste erfragen; 

673 I audit := subtext (audit, 1, LENGTH audit - 2); 

674 I IF taste = hop 

675 I THEN (♦ lernsequenz nicht auf taste legen ») (« 16.08.85 
+ I -ws- ») 

676 I ELSE lernsequenz auf taste legen (taste, audit) 

677 I FI ; 

678 I audit : = . 

679 I 

680 belegbaretasteerfragen | belegbare taste erfragen : 

681 I TEXT VAR taste; getchar (taste); 

682 I WHILE taste ist reserviert REP 

683 I benutzer warnen; getchax (taste) 

684 I PER . 

685 I 

686 tasteistreserviert | taste ist reserviert : (• 16.08.85 
+ I -ws- *) 

687 I taste <> hop CAND pos (reservierte feldeditor tasten, taste) > 0 . 

686 I 

689 lernmoduseinschalten | lernmodus einschalten : audit := ""; lernmodus := TRUE . 

690 I 

691 zumvorigenwort jzum vorigen wort : 

692 I IF stelle > 1 

693 I THEN stelle DECR 1; stelle := letzter wortanfang (satz); 

694 I alte einrueckposition raitziehen; 

695 I IF (satz SUB stelle) <> blank THEN LEAVE zum vorigen wort FI 

696 I FI ; 

697 I feldeditor verlassen . 

698 I 

699 zumnaechstenwort |zum naechsten wort : 

700 I IF kein naechstes wort THEN feldeditor verlassen FI . 

701 I 

702 keinnaechsteswort |kein naechstes wort : 

703 I BOOL VAR im alten wort := TRUE; 

704 I INT VAR i; 

705 I FOR i FROM stelle UPTO satzlaenge REP 
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706 I IF im alten wort 

707 I THEN im alten wort := (satz SUB i) <> blank 

708 I ELir (satz SUB i) <> blank 

709 I THEN stelle := i; LEAVE kein naechstes wort WITH FALSE 

710 I FI 

711 I PER; 

712 I TRUE . 

713 I 

714 belegtetasteausfuehren jbelegte taste ausfuehren : 

715 I IF ist kommando taste 

716 I THEN feldeditor verlassen 

717 I ELSE gelerntes ausfuehren 

718 I FI . 

719 I 

720 istkommando taste |ist kommando taste : taste enthaelt kommando (zweites zeichen) . 

721 I 

722 gelerntesausfuehren | gelerntes ausfuehren : 

723 I push (lernsequenz auf taste (zweites zeichen)) . 
+ I (*sh») 

724 I 

725 nachrechtsoderueberlau |nach rechts oder ueberlauf : 

726 I IF fliesstext COR stelle < limit OR satzlaenge > limit 

727 I THEN nach rechts 

728 I ELSE auf anfang der naechsten zeile 

729 I FI . 

730 I 

731 nachrechts |nach rechts : 

732 I IF stelle auf erstem halbzeichen THEN stelle INCR 2 ELSE stelle 
+ I INCR 1 FI; 

733 I alte einrueckposition mitziehen . 

734 ! 

735 aufanfangdernaechstenz |auf anfang der naechsten zeile : push (abscr) . 

736 I 

737 nachlinks jnach links : stelle DECR 1; alte einrueckposition mitziehen . 

738 I 

739 alteeinrueckpositionmi |alte einrueckposition mitziehen : 

740 I IF satz ist leerzeile 

741 I THEN alte einrueckposition := stelle 

742 I ELSE alte einrueckposition := min (stelle, einrueckposition (satz)) 

743 I FI . 

744 I 

745 satzistleerzeile |satz ist leerzeile : 

746 I satz = OR satz = blank . 

747 I 

748 wennmoeglicheinschritt |wenn moeglich ein schritt nach links : 

749 I IF stelle = ganz links 

750 I THEN zeichen ignorieren 

751 I ELSE nach links 

752 1 FI . 

753 I 
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754 zurnaechstentabulatorp |zur naechsten tabulator position : 

755 I bestimme naechste explizite tabulator position; 

756 I IF tabulator gefunden 

757 I THEN explizit tabulieren 

758 I ELIF stelle <= satzlaenge 

759 j THEN implizit tabulieren 

760 I ELSE auf anfang der naechsten zeile 

761 I FI . 

762 I 

763 bestimmenaechsteexpliz | bestimme naechste explizite tabulator position : 

764 I INT VAR tab position := pos (tabulator, dach, stelle + 1); 

765 I IF tab position > limit AND satzlaenge << limit 

766 I THEN tab position := 0 

767 I FI . 

768 I 

769 tabula torgefunden | tabulator gefunden : tab position <> 0 . 

770 I 

771 explizlttabulieren | explizit tabulieren : stelle := tab position; push (dezimal) . 

772 I 

773 Implizittabulieren | implizit tabulieren : 

774 I tab position := einrueckposition (satz); 

775 I IF stelle < tab position 

776 I THEN stelle := tab position 

777 I ELSE stelle := satzlaenge + 1 

778 I FI . 

779 I 

780 einfuegenumschalten jeinfuegen umschalten : 

781 I IF NOT write access THEN zeichen ignorieren FI; 
+ I (»sh«) 

782 I einfuegen := NOT einfuegen; 

783 I IF einfuegen THEN einfuegen optisch anzeigen FI; 

784 I feldeditor verlassen . 

785 I 

786 einfuegenoptischanzeig jeinfuegen optisch anzeigen : 

787 I IF markiert 

788 I THEN out {begin mark); markleft; out (dach left); warten; 

789 I out (end mark); markleft 

790 I ELSE out (dach left); warten; 

791 I IF stelle auf erstem halbzeichen 

792 I THEN out text (satz, stelle, stelle + 1) 

793 I ELSE out text (satz, stelle, stelle) 

794 I FI 

795 I FI . 

796 I 

797 markiert j markiert : marke > 0 . 

798 dachleft |dach left : »'*'94"»'8'*- . 

799 I 

800 warten [warten : 

801 I TEXT VAR t := incharety (2); 

802 I kommando CAT t; IF lernmodus THEN audit CAT t FI . 

803 I 
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804 elnzeichenloeschen |ein zeichen loeschen : 

805 I IF NOT write access THEN zeichen ignorieren TI; 
+ I (•sh») 

806 I IF zeichen davor soil geloescht werden 

807 I THEN nach links oder ignorieren 

808 I FI ; 

809 I IF NOT hinter dem satz THEN aiktuelles zeichen loeschen FI . 

810 I 

811 zeichendavorsollgeloes | zeichen davor soil geloescht werden : 

812 I hinter dem satz COR msLrkiert . 

813 I 

814 nachlinksoderignoriere jnach links oder ignorieren : 

815 I IF stelle > ganz links 

816 I THEN nach links 
+ I (•sh*) 

817 I ELSE zeichen ignorieren 

818 1 FI . 

819 I 

820 aktuelleszeichenloesch jaktuelles zeichen loeschen : 

821 I stelle korrigieren; alte stelle merken; 

822 I IF stelle auf erstem halbzeichen 

823 I THEN delete cheir (satz, stelle); 

824 I postblanks INCR 1 

825 j FI ; 

826 I delete char (satz, stelle); 

827 I postblanks INCR 1; 

828 I neue satzlaenge bestimmen; 

829 I output mode := out feldrest . 

830 I 

831 einezeilenachoben |eine zeile nach oben : 
■»■ I (»sh») 

832 I IF NOT absatzmarke steht CANT NOT ist teil eines 
-t- I umbruchkommandos 

833 I THEN blanks abschneiden 

834 I FI ; 

835 I push (zeichen); LEAVE feld editieren . 

836 I 

837 istteileinesumbruchkom |ist teil eines umbruchkommandos : (kommando SUB kommandozeiger) > 
+ I backer . 

838 I 

839 ggfabsatzerzeugen jggf absatz erzeugen : 
+ I (♦sh*) 

840 I IF write access 

841 I THEN IF NOT absatzmarke steht THEN blanks abschneiden FI; 

842 I IF stelle > LENGTH satz AND fliesstext AND (satz SUB LENGTH 
* I satz) <> blank 

843 I THEN satz CAT blank 

844 I FI 

845 I FI ; push (zeichen); LEAVE feld editieren . 

846 I 

847 markierenufflschalten jmarkieren umschalten : 

848 I IF markiert 

849 I THEN marke := 0; maxschreibpos INCR marklength; epos DECR 
-»■ I marklength 

850 I ELSE marke := stelle; maxschreibpos DECR marklength; epos INCR 

I marklength ; 
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851 I verschieben wenn erforderlich 

852 I FI ; 

853 I feldeditor verlassen . 

854 I 

855 sondertastebehandeln [sondertaste behandeln : push (esc + zeichen) . 

856 I END PROC feldeditor; 

857 I 

858 dezimaleditor |PROC dezimaleditor (TEXT VAR satz) : 

859 I INT VAR dezimalanfang := stelle; 

860 I zeichen einlesen; 

861 I IF dezimalstartzeichen CAND ueberschreibbar THEN dezimalen 
+ I schreiben FI; 

862 I push (zeichen) . 

863 I 

864 zeicheneinlesen | zeichen einlesen : TEXT VAR zeichen; getchar (zeichen) . 

865 dezimalzeichen jdezimalzeichen : pos (dezimalen, zeichen) > 0 AND nicht 
+ I separator . 

866 dezimalstartzeichen | dezimalstartzeichen : pos (startdezimalen, zeichen) > 0 AND nicht 
+ I separator . 

867 dezimalen | dezimalen : •*0123456789" . 

868 startdezimalen j startdezimalen : "+-0123456789" . 

869 nicht separator | nicht separator : pos (separator, zeichen) = 0 . 

870 I 

871 ueberschreibbar [ueberschreibbar : 

872 I dezimalanfang > LENGTH satz OR 

873 I pos (ueberschreibbare zeichen, satz SUB dezimalanfang) > 0 . 

874 I 

875 ueberschreibbarezeiche | ueberschreibbare zeichen : " ,.+-0123456789** . 

876 I 

877 deziroalenschreiben [dezimalen schreiben : 

878 I REP 

879 1 dezimale in satz eintragen; 

880 I dezimalen zeigen; 

881 I zeichen einlesen; 

882 I dezimalanfang DECR 1 

883 I UNTIL dezimaleditor beendet PER; 

884 I stelle INCR 1 . 

885 I 

886 dezimale insatze in trage [dezimale in satz eintragen : 

887 I IF dezimalanfang > LENGTH satz 

888 I THEN satz AUFFUELLENMIT blank; satz CAT zeichen 

889 I ELSE delete char (satz, dezimalanfang); insert char (satz, 
+ I zeichen, stelle) 

890 I FI . 

891 I 

892 dezimalenzeigen [dezimalen zeigen : 

893 I INT VAR min dezimalschreibpos := max (min schreibpos, 
+ [ dezimalanfang) ; 
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894 I IF markiert THEN markiert zeigen ELSE unmarkiert zeigen FI; 

895 I schreibmarke positionieren (stelle) . 

896 1 

897 markiert [markiert : marke > 0 . 

898 I 

899 markiertzeigen | markiert zeigen : 

900 I invers out (satz, min dezimalschreibpos, stelle, end mark); 

901 I out (zeichen) . 

902 I 

903 unmarkiertzeigen | unmarkiert zeigen : 

904 I schreibmarke positionieren (min dezimalschreibpos); 

905 I out subtext (satz, min dezimalschreibpos, stelle) . 

906 I 

907 dezimaleditorbeendet jdezimaleditor beendet : 

908 I NOT dezimalzeichen OR 

909 I dezimalanfang < max (min schreibpos, marke) OR 

910 I NOT ueberschreibbar . 

911 I END PRCX3 dezimaleditor; 

912 I 

913 iseditget |BOOL PROC is editget : 

914 I editget modus 

915 I END PROC is editget ; 

916 I 

917 geteditline |PROC get editline (TEXT VAR editline, INT VAR editpos, editroarke) : 

918 I IF editget modus 

919 I THEN editline := alter editsatz; 

920 I editpos := stelle 

921 I FI ; 

922 I editmarke := marke 

923 I END PROC get editline; 

924 I 

925 puteditline |PROC put editline (TEXT CONST editline, INT CONST editpos, 

+ I editmarke) : 

926 I IF editget modus 

927 I THEN alter editsatz := editline; 

928 I stelle := max (editpos, 1); 

929 I marke := max (editmarke, 0) 

930 I FI 

931 I END PROC put editline; 

932 I 

933 withinkanji |BOOL PROC within kanji (TEXT CONST satz, INT CONST stelle) : 

934 I count directly prefixing kanji esc bytes; 

935 I number of kanji esc bytes is odd . 

936 I 

937 countdirectlyprefixing [count directly prefixing kanji esc bytes : 

938 I INT VAR pos := stelle - 1, kanji esc bytes := 0; 

939 1 WHILE pos > 0 CAND is kanji esc (satz SUB pos) REP 

940 j kanji esc bytes INCR 1; pos DECR 1 

941 I PER . 
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942 I 

943 numberofkanjiescbytesi | number of kanji esc bytes Is odd : 

944 I (kanJi esc bytes AND 1) <> 0 . 

945 I END PROC within kanji; 

946 I 

947 iskanjiesc |BOOL PROC is kanJi esc (TEXT CONST char) : 

+ I (*sh») 

948 I two byte mode CAND 

949 I (char >= ""129"*' AND char <= **"159*'" OR char >= '"•224"" AND char 
+ I <= -"239'*'') 

950 lEND PROC is kanji esc; 

951 I 

952 twobytes |BOOL PROC two bytes : two byte mode END PROC two bytes; 

953 i 

954 twobytes | PROC two bytes ( BOOL CONST new mode ) : 

955 I two byte mode := new mode 

956 I END PROC two bytes; 

957 I 

958 outtext |PROC outtext (TEXT CONST source, INT CONST from, to) : 

959 I out subtext mit randbehandlung (source, from, to); 

960 I INT VAR trailing; 

961 I IF from <= LENGTH source 

962 I THEN trailing := to - LENGTH source 

963 I ELSE trailing := to - from ■»• 1 

964 1 FI ; trailing TIMESOUT blank 

965 I END PROC outtext; 

966 I 

967 outsubtextmitrandbehan ...|PROC out subtext mit randbehandlung (TEXT CONST satz, INT CONST von, 
+ I bis) : 

968 I IF von > bis 

969 I THEN 

970 I ELIF bis >= LENGTH satz COR NOT within kanji (satz, bis + 1) 

971 I THEN out subtext mit anfangsbehandlung (satz, von, bis) 

972 I ELSE out subtext mit anfangsbehandlung (satz, von, bis - 1); out 
+ I (blank) 

973 I FI 

974 I END PROC out subtext mit randbehandlung; 

975 j 

976 outsubtextmitanfangsbe ...|PR(X3 out subtext mit anfangsbehandlung (TEXT CONST satz, INT CONST 
+ I von, bis) : 

977 I IF von > bis 

978 I THEN 

979 I ELIF von « 1 COR NOT within kanji (satz, von) 

980 I THEN out subtext (satz, von, bis) 

981 I ELSE out (blank); out subtext (satz, von -t- 1, bis) 

982 I FI 

983 I END PROC out subtext mit anfangsbehandlung; 

984 I 
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985 gotcursor 



986 



987 xcursor 

+ 

988 

989 writepermission 
+ 

990 



push 



replacemoegl i ch 



991 
992 
+ 

993 
994 
995 
996 
997 
998 
999 
1000 
1001 
1002 
1003 

1004 
1005 
1006 
1007 
1008 



1009 type 

1010 
1011 
1012 

1013 stelleamanfang 

+ 

1014 

1015 stelleamende 

+ 

1016 

1017 markierausgleich 

+ 

1018 

1019 verschiebenwennerforde 

1020 

1021 

1022 



PROC get cursor 
cursor; 



get cursor (spalte, zeile) 



INT PROC X cursor : get cursor; spalte 
cursor; 



END PROC get 



END PROC X 



BOOL PROC write permission : write access END PROC write 
permission; 



PROC push (TEXT CONST ausfuehrkommando) : 
IF ausfuehrkommando = 
( »sh» ) 

THEN 

ELIF kommando . 

THEN kommando := ausfuehrkommando 

ELIF (kommando SUB kommando zeiger - 1) « ausfuehrkommando 
THEN kommando zeiger DECR 1 
ELIF replace moeglich 

THEN kommando zeiger DECR laenge des ausf uehrkommandos ; 

replace (kommando, kommando zeiger, ausfuehrkommando) 
ELSE insert char (kommando, ausfuehrkommando, kommando zeiger) 
FI . 



replace moeglich : 

INT CONST laenge des ausf uehrkommandos := LENGTH ausfuehrkoonando; 

kommando zeiger > laenge des ausfuehrkommandos . 
END PROC push; 



PROC type (TEXT CONST ausfuehrkommando) : 

kommando CAT ausfuehrkommando 
END PROC type; 



INT PROC stelle am anfang : anfang + verschoben END PROC stelle 
anfang; 



INT PROC stelle am ende : stelle am anfang-»-laenge-l END PROC 
stelle am ende; 



INT PROC markierausgleich : SIGN roaxke • marklength END PROC 
markierausgleich; 



PROC verschieben wenn erforderlich : 
IF stelle > max schreibpos 
THEN verschiebe (stelle - max schreibpos) 
ELIF stelle < min schreibpos 
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verschiebe 



konstantenneuberechnen . . . 



schreibmarkepositionie . . . 



simple feldout 



schre i bmarkeanf e Idanf a 



feldout 



schre i bmarkeanf e Idanf a 



THEN verschiebe (stelle - min schreibpos) 
FI 

END PROC verschieben wenn erf order lich; 



PROC verschiebe (INT COUST i) : 

verschoben INCR i; 

min schreibpos INCR i; 

max schreibpos INCR i; 

epos DECR i; 

output mode := out feld; 

schreibmarke positionieren (stelle) 
-ws- •) 
END PROC verschiebe; 



(» 11.05.85 



(* 17.05.85 



PROC konstanten neu berechnen : 
min schreibpos := anfang + verschoben; 
IF min ichreibpos < 0 
-ws- ») 

THEN min schreibpos DECR verschoben; verschoben ;= 0 
FI ; 

max schreibpos := min schreibpos + laenge - 1 - markierausglelch; 
epos := rand + laenge - max schreibpos 
END PROC konstanten neu berechnen; 



PROC schreibmarke positionieren (INT CONST sstelle) 

cursor (epos -^ sstelle, zeile) 
END PROC schreibmarke positionieren; 



PROC simple feldout (TEXT CONST satz, INT CONST dummy) : 
(• PRECONDITION : NOT markiert AND verschoben = 0 ») 
(« AND feldrest schon geloescht ») 

schreibmarke an feldanfang positionieren; 

out subtext mit randbehandlung (satz, anfang, anfang + laenge - 1) 
IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben 
(TRUE) FI . 



schreibmarke an feldanfang positionieren : cursor (rand + 1, 
END PROC simple feldout; 



zeile) 



PROC feldout (TEXT CONST satz, INT CONST sstelle) : 
schreibmarke an feldanfang positionieren; 
feld ausgeben; 
feldrest loeschen; 

IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben 
(TRUE) FI . 



schreibmarke an feldanfang positionieren : cursor (rand + 1, zeile) 
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1067 feldausgeben |feld ausgeben : 

1068 I INT VAR von := anfang + verschoben, bis := von + laenge - 1; 

1069 I IF nicht markiert 

1070 I THEN unmarkiert ausgeben 

1071 I ELIF markiertes nicht sichtbar 

1072 j THEN unmarkiert ausgeben 

1073 I ELSE markiert ausgeben 

1074 I FI . 

1075 I 

1076 nichtmarkiert j nicht markiert : marke <= 0 . 

1077 I 

1078 markiertesnichtsichtba [markiertes nicht sichtbar : 

1079 I bis DECR marklength • (1 + SIGN sstelle); marke > bis + 1 . 

1080 I 

1081 unnarkiertausgeben | unmarkiert ausgeben : 

1082 I out subtext mit randbehandlung (satz, von, bis) . 

1083 I 

1084 markiertausgeben | markiert ausgeben : 

1085 I INT VAR smarke := max (von, marke); 

1086 I out text (satz, von, smarke - 1); out (begin mark); 

1087 I verschiedene feldout modes behandeln . 

1088 I 

1089 verschiedene feldoutmod | verschiedene feldout modes behandeln : 

1090 I IF sstelle = 0 

1091 I THEN out subtext mit randbehandlung (satz, smarke, bis); out (end 
+ I mark ) 

1092 I ELSE out text (satz, smarke, zeilenrand); out (end mark); 
+ I ( *»sh» ) 

1093 I out subtext mit randbehandlung (satz, sstelle, bis) 

1094 I FI . 

1095 I 

1096 zeilenrand | zeilenrand : min (bis, sstelle - 1) . 

1097 I END PROC feldout; 

1098 I 

1099 absatzmarkeschreiben |PROC absatzmarke schreiben (BOOL CONST schreiben) : 

1100 I IF fliesstext AND nicht markiert 

1101 I THEN cursor (rand + 1 + laenge, zeile); 

1102 I out (absatzmarke) ; 

1103 I absatzmarke steht := TRUE 

1104 I FI . 

1105 I 

1106 nichtmarkiert | nicht markiert : marke <= 0 . 

1107 I 

1108 absatzmarke | absatzmarke : 

1109 I IF NOT schreiben 

1110 I THEN " " 

1111 I ELIF marklength > 0 
lllP I THEN '•"i5''«i4"'' 

1113 I ELSE ""15" "14" " 

1114 I FI . 

1115 I END PROC absatzmarke schreiben; 

1116 I 
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1117 inversout |PROC invers out (TEXT CX)NST satz, INT CONST von, bis, TEXT CONST 

+ I pre, post) : 

1118 I IF mark refresh line mode 

1119 I THEN feldout (satz, stelle) 

1120 I ELSE schreibmarke positionieren (von); 

1121 I out (begin mark); markleft; out (pre); 

1122 I out text (satz, von, bis - 1); out (post) 

1123 I FI . 

1124 I 

1125 markleft | markleft ; 

1126 I marklength TIMESOUT left . 

1127 I 

1128 I END PROC invers out; 

1129 I 

1130 feldrestloeschen |PROC feldrest loeschen : 

1131 I IF rand laenge < maxbreite COR invertierte darstellung 

1132 I THEN INT VAR x; get cursor (x, zeile); 

1133 j (rand + laenge - x + 1 + absatz ausgleich) TIMESOUT blank; 
+ I ( »sh* ) 

1134 I cursor (x, zeile) 

1135 I ELSE out (clear eol); absatzmarke steht FALSE 

1136 I FI 

1137 I END PROC feldrest loeschen; 

1138 I 

1139 AUFFUELLENMIT |0P AUFFUELLENMIT (TEXT VAR satz, TEXT CONST fuellzeichen) : 

1140 I INT VAR i; 

1141 1 FOR i FROM stelle - LENGTH satz DOWNTO 2 REP 

1142 I satz CAT fuellzeichen 

1143 I PER 

1144 I END OP AUFFUELLENMIT; 

1145 j 

1146 einrueckposition |INT PROC einrueckposition (TEXT CONST satz) : 

+ I (•sh*) 

1147 I IF fliesstext AND satz = blank 

1148 I THEN anfang 

1149 I ELSE max (pos (satz, ""SS*"*, ""254*'", 1), 1) 

1150 I FI 

1151 I END PROC einrueckposition; 

1152 I 

1153 letzterwortanfang |INT PROC letzter wortanfang (TEXT CONST satz) : 

+ I (-sh**) 

1154 I INT CONST ganz links := max (1, marke); 

1155 I BOOL VAR noch nicht im neuen wort := TRUE; 

1156 I INT VAR i; 

1157 I FOR i FROM stelle DOWNTO ganz links REP 

1158 I IF noch nicht im neuen wort 

1159 I THEN noch nicht im neuen wort :» char = blank 

1160 I ELIF is kanji esc (char) 

1161 I THEN LEAVE letzter wortanfang WITH i 

1162 I ELIF nicht mehr im neuen wort 

1163 I THEN LEAVE letzter wortanfang WITH i + 1 

1164 I FI 

1165 I PER ; 
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1166 I ganz links . 

1167 I 

1168 char jchar : satz SUB i . 

1169 I 

1170 nichtmehrimneuenwort |nicht mehr im neuen wort : char = blank COR within kanji (satz, i) 

1171 lEND PROC letzter wortanfang; 

1172 I 

1173 getchar |PROC getchar (TEXT VAR zeichen) : 

1174 I IF konunando = 

1175 I THEN inchar (zeichen); IF lernmodus THEN audit CAT zeichen FI 

1176 I ELSE zeichen := konunando SUB komroando zelger; 

1177 I konunando zeiger INCR 1; 

1178 I IF konunando zeiger > LENGTH konmando 

1179 I THEN konunando zeiger := 1; konanando :» 

1180 I FI ; 

1181 I IF LENGTH konunando - konunando zeiger < 3 

1182 I THEN konunando CAT inchety 

1183 I FI 

1184 I FI . 

1185 I END PROC getchar; 

1186 I 

1187 inchety |TEXT PROC inchety : 

1188 I IF lernmodus 

1189 I THEN TEXT VAR t := incharety; audit CAT t; t 

1190 I ELSE incharety 

1191 I FI 

1192 I END PROC inchety; 

1193 I 

1194 isincharety |BOOL PROC is incharety (TEXT CONST muster) : 

1195 I IF kommando = 

1196 I THEN TEXT CONST t := inchety; 

1197 I IF t = muster THEN TRUE ELSE konunando := t; FALSE FI 

1198 I ELIF (konunando SUB kommando zeiger) = muster 

1199 I THEN kommando zeiger INCR 1; 

1200 I IF kommando zeiger > LENGTH konunando 

1201 I THEN kommando zeiger := 1; kommando := "** 

1202 I FI ; 

1203 I TRUE 

1204 I ELSE FALSE 

1205 I FI 

1206 I END PROC is incharety; 

1207 I 

1208 getch€a^ty |TEXT PROC getcharety : 

1209 I IF kommando = **" 

1210 I THEN inchety 

1211 I ELSE TEXT CONST t := kommando SUB kommando zeiger; 

1212 I kommando zeiger INCR 1; 

1213 I IF kommando zeiger > LENGTH kommando 

1214 I THEN kommando zeiger := 1; kommando := 

1215 I FI ; t 

1216 I FI 

1217 I END PROC getcharety; 
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1218 



1219 geteditcursor 
+ 

1220 
1221 
1222 
1223 



1224 
1225 
1226 



1244 
1245 
+ 

1246 
1247 
1248 
1249 
1250 
1251 
1252 
1253 
1254 
1255 
1256 

1257 
1258 
1259 



aktualisierebildparame 



PROC get editcursor (INT VAR x, y) : 
(*sh«) 

IF actual editor > 0 THEN aktualisiere bildparauneter FI; 

X := rand - (anfang + verschoben - 1 - markierausgleich) + stelle; 

y := zeile . 



aktualisiere bildparameter : 

INT VAR old X, old y; get cursor (old x, old y); 
dateizustand holen; bildausgabe steuern; satznr zeigen; 



1227 




1 fenster 


zeigen; zeile 


:= bildrand 


+ 




1 y) 






1228 




|END PROC get editcursor; 




1229 










1230 
+ 








» Zugriff auf 


1231 




1 






1232 


stelle 


1 stelle 


: feldstatus 


.stelle . 


1233 


a>X UOd box J.O 


jalte stelle 


: feldstatus 


• ClX UC7 O UDXxO 


1234 


rand 


jrand 


: feldstatus 


rand . 


1235 


limit 


1 limit 


: feldstatus 


limit . 


1236 


anfang 


1 anfang 


: feldstatus 


anfang . 


1237 


marke 


1 marke 


: feldstatus 


marke . 


1238 


laenge 


1 laenge 


: feldstatus 


laenge . 


1239 


verschoben 


1 verschoben 


: feldstatus 


verschoben . 


1240 


einfuegen 


1 einfuegen 


: feldstatus 


einfuegen . 


1241 


fliesstext 


1 fliesstext 


: feldstatus 


fliesstext . 


1242 


writeaccess 


[write access 


: feldstatus. 


write access 


1243 


tabulator 


1 tabulator 


: feldstatus. 


tabulator . 



LET undefinierter bereich = 0, 

bildzeile = 2, 

abschnitt = 3, 

bild = 4, 



nix = 1, 

akt satznr = 2, 

uoberschrift = 3, 

fehlerraeldung = 4; 



LET BILDSTATUS = STRUCT (INT feldlaenge, kurze feldlaenge, 

bildrand, bildlaenge, kurze bildlaenge, 
ueberschriftbereich, bildbereich, 
erster neusatz, letzter neusatz, 
old zeilennr, old lineno, old mark 
lineno , 

BOOL zeileneinfuegen, old line update, 
TEXT satznr pre, ueberschrift pre, 

ueberschrift text, ueberschrift post, 
old satz. 
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1260 I FRANCE old range, 

1261 I FILE file), 

1262 I EDITSTATUS = STRUCT (FELDSTATUS feldstatus, BILDSTATUS 
+ I bildstatus), 

1263 I max editor = 10, 

1264 i EDITSTACK = ROW max editor EDITSTATUS; 

1265 I 

1266 I BILDSTATUS VAR bildstatus ; 

1267 I EDITSTACK VAR edits tack; 

1268 I 

1269 I ROW max editor INT VAR einrueckstack; 

1270 j 

1271 I BOOL VAR markiert; 

1272 I TEXT VAR filename, tab, bildsatz, bildzeichen, fehlertext, 

1273 I akt bildsatz ; 

1274 I INT VAR zeilennr, satznr, bildanfang, bildmarke, feldmarke, 

1275 I actual editor := 0, max used editor := 0, 

1276 I letzer editor auf dieser datei, 

1277 I alte einrueckposition := 1; 

1278 I 

1279 aktuellereditor | INT PROC aktueller editor : actual editor END PROC aktueller 

+ I editor; 

1280 I 

1281 groesstereditor | INT PROC groesster editor : max used editor END PROC groesster 

+ I editor; 

1282 j 

1284 I 

1285 bildeditor |PROC bildeditor (TEXT CONST res, PROC (TEXT CONST) kommando 

+ I interpreter) : 

1286 I evtl fehler behandeln; 

1287 I enable stop; 

1288 I TEXT VAR reservierte tasten := "*'ll*'*'12*'*'27*'bf*' ; 

1289 I reservierte tasten CAT res ; 

1290 j INT CONST my highest editor := max used editor; 

1291 I laenge := feldlaenge; 

1292 I konstanten neu berechnen; 

1293 I REP 

1294 I markierung justieren; 

1295 I altes feld nachbereiten; 

1296 I feldlaenge einstellen; 

1297 I ueberschrift zeigen; 

1298 I fenster zeigen ; 

1299 1 zeile bereitstellen; 

1300 I zeile editieren; 

1301 I kommando ausfuehren 

1302 I PER . 

1303 I 

1304 evtlfehlerbehandeln |evtl fehler behandeln : 

1305 I IF is error 

1306 I THEN fehlertext := errormessage; 

1307 I IF fehlertext <> "** THEN neu (fehlermeldung, nix) FI; 

1308 I clear error 

1309 I ELSE fehlertext := 
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1310 
1311 

1312 markierungjustieren 

1313 

1314 

1315 

1316 

1317 

1318 

1319 

1320 

1321 

1322 zeilebereitstellen 



1323 hinterletztemsatz 
1324 

1325 altesfeldnachberelten 

1326 

1327 

1328 

1329 

1330 

1331 

1332 
1333 
1334 
1335 
1336 
1337 
1338 
1339 
1340 
1341 
1342 
1343 
1344 

1345 feldlaengeeinstellen 

1346 

1347 

1348 

1349 

1350 

1351 

1352 

1353 

1354 

1355 zelleeditieren 
1356 
1357 
•»■ 

1358 
1359 
1360 
1361 
1362 



ri . 



markierung justieren : 
IF bildmarke > 0 
THEN IF satznr <= bildmarke 
THEN bildmarke := satznr; 

stelle := max (stelle, feldmarke); 
marke := feldmarke 
ELSE marke := 1 
FI 

FI . 



zeile bereitstellen : IF hinter letztem satz THEN insert record 
! (file) FI . 

hinter letztem satz : lineno (file) > lines (file) . 



altes fold nachbereiten : 

IF old line update AND lineno (file) <> old lineno 
THEN IF verschoben <> 0 

THEN verschoben := 0; konstanten neu berechnen; 

FI ; 

INT CONST alte zeilennr :« old lineno - bildanfang + 1; 
IF alte zeilennr > © AND alte zeilennr <= aktuelle 

bildlaenge 
THEN INT CONST m := marke; 

IF lineno (file) < old lineno 

THEN marke := 0 

ELIF old lineno = bildnwurke 

THEN marke := min (feldmarke, LENGTH old. satz + 1) 
ELSE marke := min ( marke » LENGTH old satz + 1) 
FI ; 

zeile := bildrand + alte zeilennr; 
feldout (old satz, 0); marke := m 

FI 

FI ; 

old line update := FALSE; old satz := . 



feldlaenge elnstellen : 

INT CONST alte laenge := laenge; 
IF zeilennr > kurze blldlaenge 
THEN laenge := kurze feldlaenge 
ELSE laenge :» feldlaenge 
FI ; 

IF laenge < > alte laenge 
THEN konstanten neu berechnen 
FI . 



zeile editieren : 
zeile := bildrand + zeilennr; 

exec (PROG (TEXT VAR, TEXT CONST) feldeditor, file, reservierte 

tasten) ; 
old lineno := satznr; 
IF markiert Oder verschoben 

THEN old line update := TRUE; read record (file, old satz) 
FI . 
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1363 markiertodervorschoben |marklert oder verschoben : raarklert COT verschoben <> 0 . 

1364 j 

1365 kommandoausfuehren Ikommando ausfuehren : 

1366 I getchar (bildzeichen) ; 

1367 I SELECT pos (kommandos, bildzeichen) OF 

1368 I CASE X hop : hop kommando verarbeiten 

1369 I CASE X esc : esc kommando verarbeiten 

1370 I CASE X up : zum vorigen satz 

1371 I CASE X down : zum folgenden satz 

1372 I CASE X rubin : zeicheneinfuegen umschalten 

1373 I CASE X mark : markierung umschalten 

1374 I CASE X cr : eingerueckt mit cr (» 06.06.6! 
+ I -ws- ») 

1375 I CASE X inscr : eingerueckt zum folgenden satz 

1376 I CASE X abscr : zum anfang des folgenden satzes 

1377 I END SELECT . 

1378 I 

1379 kommandos (kommandos : 

1380 I LET X hop =1, x up - 2, 

1381 I x down =3, x rubin = 4, 

1382 I X cr = 5, x mark = 6, 

1383 I X abscr =7, x inscr = 8, 

1384 I X esc - 9; 

1385 I 

1386 I »'"i-'»3«-i0»»"ii»'"i3""i6"*'17"*'18'"*27''*' . 

1387 I 

1388 zeicheneinfuegenumscha | zeicheneinfuegen umschalten : 

1389 I rubin segment in ueberschrift eintragen; 

1390 I neu (ueberschrift, nix) . 

1391 I 

1392 rubinsegmentinuebersch | rubin segment in ueberschrift eintragen : 

1393 I replace (ueberschrift text, 9, rubin segment) . 

1394 I 

1395 rubinsegment | rubin segment : 

1396 I IF einfuegen THEN "RUBIN" ELSE " " FI . 

1397 I 

1398 hopkommandoverarbeiten |hop kommando verarbeiten : 

1399 I getchar (bildzeichen); 

1400 I read record (file, bildsatz); 

1401 I SELECT pos (hop kommandos, bildzeichen) OF 

1402 I CASE y hop : nach oben 

1403 I CASE y cr : neue seite 

1404 I CASE y up : zurueckblaettern 

1405 I CASE y down : weiterblaettern 

1406 I CASE y tab : put tabs (file, tabulator); neu (ueberschrift, 
+ I nix) 

1407 I CASE y rubout : zeile loeschen 

1408 I CASE y rubin : zeileneinfuegen umschalten 

1409 I ENL SELECT . 

1410 I 

1411 hopkommandos |hop kommandos : , 

1412 I LET y hop =1, y up x 2, 

1413 I y tab =3, y down = 4, ^ 

1414 I y rubin =5, y rubout « 6, 

1415 I y cr =7; 
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1416 I 

1417 I «»i«*»3»»«9'»«i0"«ii«"i2'"'13"'* . 

1418 I 

1419 zeileneinfuegenutnschal jzeileneinfuegen umschalten : 

1420 I zeileneinfuegen := NOT zeileneinfuegen; 

1421 I IF zeileneinfuegen 

1422 I THEN zeile aufspalten; logisches eof setzen 

1423 I ELSE leere zeile am ende loeschen; logisches eof loeschen 

1424 I FI ; restbild zeigen . 

1425 I 

1426 zeileaufspalten j zeile aufspalten : 

1427 I IF stelle <= LENGTH bildsatz OR stelle « 1 

1428 I THEN loesche ggf trennende blanks und spalte zeile 

1429 I FI , 

1430 I 

1431 loescheggftrennendebla | loesche ggf trennende blanks und spalte zeile: (« 26.06.84 
+ I -bk- •) 

1432 I INT VAR first non blank pes := stelle; 

1433 I WHILE first non blank pos <= length (bildsatz) CAND 

1434 I (bildsatz SUB first non blank pos) = blank REP 

1435 I first non blank pos INCR 1 

1436 I PER ; 

1437 I split line and Indentation; 
+ I ( •sh* ) 

1438 I first non blank pos := stelle - 1; 

1439 I WHILE first non blank pos >= 1 CAND 

1440 I (bildsatz SUB first non blank pos) = blank REP 

1441 I first non blank pos DECR 1 

1442 I PER; 

1443 I bildsatz := subtext (bildsatz, 1, first non blank pos); 

1444 I write record (file, bildsatz) . 

1445 I 

1446 splitlineandindentatio | split line and indentation : 

1447 I split line (file, first non blank pos, TRUE) . 

1448 I 

1449 loglscheseofsetzen [logisches eof setzen : 

1450 I down (file); col (file, 1); 

1451 I set range (file, 1, 1, old range); up (file) . 

1452 I 

1453 leerezeileamendeloesch j leere zeile am ende loeschen : 

1454 I to line (file, lines (file)); 

1455 I IF len (file) = 0 THEN delete record (file) FI; 

1456 I to line (file, satznr) . 

1457 I 

1456 logischeseof loeschen [logisches eof loeschen : 

1459 I col (file, stelle); set range (file, old range) . 

1460 I 

1461 restbildzeigen [restbild zeigen : 

1462 I erster n6usatz := satznr; 

1463 I letzter neusatz := bildanfang + bildlaenge - 1; 

1464 j rest segment in ueberschrift elntragen; 

1465 I neu (ueberschrift, abschnitt) . 

1466 I 
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1467 
1468 
1469 

1470 
1471 
1472 

1473 
1474 
1475 

■f 

1476 
1477 
1478 
1479 
1480 

1481 
+ 

1482 
1483 
1484 
1485 

1486 

1487 

1488 
1489 

1490 
1491 
1492 

1493 
1494 

1495 
1496 
1497 
1498 
1499 
1500 
1501 
1502 
1503 
1504 
1505 
1506 
1507 
1508 

1509 
1510 
1511 
1512 
1513 
1514 
1515 
1516 



restsegmentinueberschr 



restsegment 



esckommandoverarbeiten 



eventuellzeichenzuruec 



erlaubte taste 

zu lae s s igeze iche n 

benutzerwarnen 

endenachquit 

tasteistreserviert 
festvordefinierteescfu 



esckommandos 



rest segment in ueberschrift eintragen : 
replace (ueberschrift text, feldlaenge 



rest segment : 

IF zeileneinfuegen THEN "REST** ELSE 



25, rest segment) 



FI 



esc kommando verarbeiten : 
getchar (bildzelchen) ; 

eventuell zeichen zurueckweisen; (« 04.05.85 

-ws- •) 
IF taste ist reserviert 
THEN belegte taste ausfuehren 
ELSE fest vordefinierte esc funktion 
FI ; ende nach quit . 



eventuell zeichen zurueckweisen : (•04.05.85 
-ws- «) 

IF NOT write access CAND NOT erlaubte taste 
THEN benutzer warnen; LEAVE kommando ausfuehren 
FI . 



erlaubte taste : pos (zulaessige zeichen, bildzeichen) > 0 . 
zulaessige zeichen : res + "*'l*'*'2*'*'8*'"27**bfq*' . 
benutzer warnen : out (piep) . 



ende nach quit : 

IF max used editor < my highest editor THIN LEAVE bildeditor FI 



taste ist reserviert : pos (res, bildzeichen) > 0 . 



fest vordefinierte esc funktion : 
read record (file, bildsatz); 
SELECT pos (esc komraandos, bildzeichen) OF 



CASE 
CASE 
CASE 
CASE 
CASE 
CASE 
CASE 
CASE 
OTHERWISE 
END SELECT 



hop 
esc 
left 
right 
b 
f 

rubout 
rubin 



lernmodus umschalten 
kommandodialog versuchen 
zum vorigen wort 
zum naechsten wort 
bild an aktuelle zeile angleichen 
belegte taste ausfuehren 
markiertes vorsichtig loeschen 
vrrsichtig geloeschtes einfuegen 
belegte taste ausfuehren 



esc kommandos : 
LET z hop 
z left 
z rubout 
z b 



1, 
3, 
5, 
7, 



z right 
z rubin 
z esc 
z f 



= 2, 

= 4. 

« 6, 

= 8; 



21/31 



editor paket 



21/31 



Zeile •♦•» ELAN EUMEL 1.8 •••• 10.11.86 editor paket 

1517 zumvorigenwort |zum vorigen wort : 

1518 I IF vorgaenger erlaubt 

1519 I THEN vorgaenger; read record (file, bildsatz); 

1520 I stelle := LENGTH bildsatz + 1; push (esc + left) 

1521 i FI . 

1522 I 

1523 vorgaengererlaubt | vorgaenger erlaubt : 

1524 I satznr > max. (1, bildmarke) . 

1525 I 

1526 zuranaechstenwort jzum naechsten wort : 

1527 I IF nicht auf letztem satz THEN weitersuchen wenn nicht gefunden FI 
+ I 

1528 I 

1529 nlchtaufletztemsatz | nicht auf letztem satz : line no (file) < lines (file) . 

1530 I 

1531 weitersuchenwennnichtg | weitersuchen wenn nicht gefunden : 

1532 I nachfol^enden satz holen; 

1533 I IF ( nachf olgender satz SUB anfang) « blank 

1534 I THEN push (abscr + esc + right) 

1535 I ELSE push (abscr) 

1536 I FI . 

1537 I 

1538 nachfolgendensatzholen | nachf olgenden satz holen : 

1539 I down (file); read record (file, nachfol^ender satz); up (file) . 

1540 I 

1541 bildanaktuellezeileang jbild an aktuelle zeile angleichen : 

1542 I anfang INCR verschoben; verschoben := 0; 

1543 I margin segment in ueberschrift eintragen; 

1544 I neu (ueberschrift, bild) . 

1545 I 

1546 marginsegmentinuebersc [margin segment in ueberschrift eintragen : 

1547 I replace (ueberschrift text, 2, margin segment) . 

1548 I 

1549 marginsegment | margin segment : 

1550 I IF anfang <= 1 

1551 I THEN *• " 

1552 I ELSE TEXT VAR margin text := "M" text (anfang); 

1553 I (6 - LENGTH margin text) • + margin text 

1554 I FI . 

1555 I 

1556 belegtetasteausfuehren jbelegte taste ausfuehren : 

1557 I kommando analysieren (bildzelchen, PROC(TEXT (X>NST) kommando 
+ I interpreter) . 

1558 I 

1559 kommandodialogversuche | kommandodialog versuchen: 

1560 I IF fenster ist zu schmal fuer dialog 

1561 I THEN kommandodialog ablehnen 

1562 I ELSE kommandodialog fuehren 

1563 I FI . 

1564 1 
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1565 fensteristzuschmalfuer 
1566 

1567 konunandodialogablehnen 

1568 

1569 

157© kommandodialogfuehren 
1571 
1572 
1573 
1574 
1575 
1576 
1577 
1578 
1579 
1580 
1581 
1582 
■f 

1583 
1584 
1585 
1586 
1587 
1588 
1589 
1590 
1591 

1592 kommandozeileeditieren 

1593 

1594 

1595 

1596 

1597 

1598 

1599 

1600 

1601 

1603 

1604 darstellunginvertieren 
1605 

1606 
1607 

1608 editgetschleife 

1609 

1610 

1611 

1612 

1613 

1614 

1615 

1616 

1617 

1618 

1619 



fenster 1st zu schmal fuer dialog : laenge < 20 . 



kommandodialog ablehnen : 

fehlertext :» "zu schraal fuer ESC ESC*; neu (fehlermeldung, nix) 



konunandodialog fuehren: 
INT VAR x0, xl, x2, x3, y; 
get cursor (x0, y) ; 

cursor (rand + 1, bildrand + zeilennr); 
get cursor ( xl , y ) ; 

out (begin mark); out (monitor meldung); 
get cursor (x2, y) ; 

(laenge - LENGTH monitor meldung - marklength) TIMESOUT blank; 
get cursor (x3, y) ; 
out (end mark); out (blank); 
kommandozeile editleren; 
ueberschrift zeigen; 
absatz ausgleich := 2; 
(*sh«) 

IF kommandotext = THEN LEAVE konnandodialog fuehren FI; 

kommando auf taste legen (**f**, kommandotext); 

kommando analysieren (*'f*', PROC(TEXT CONST) kommando interpreter) 

IF fehlertext <> 

THEN push (esc + esc + esc + "k**) 

ELIF markiert 

THEN zeile neu 

FI . 



kommandozeile editieren : 
TEXT VAR kommandotext := **"; 
cursor (xl, y); out (begin mark); 
disable stop; 
darstellung invertieren; 
editget schleife; 
dar s te 1 lung i nver t i ere n ; 
enable stop; 

cursor (x3, y); out (end mark); 

exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle); 
cursor (x0, y) . 



darstellung invertieren : 
TEXT VAR dummy := begin mark; begin mark end mark; end mark 
dummy; 

invertierte darstellung := NOT invertierte darstellung . 



editget schleife : 
TEXT VAR exit char; 
REP 

cursor (x2, y) ; 

editget (kommandotext, max textlength, rand laenge - x cursor 

-k?!", exit char); 
neu (ueberschrift, nix); 
IF exit char = "*»27''k*' 

THEN kommando text :» kommando auf taste ("f") 

ELIF exit char = »'"27"?" 

THEN TEXT VAR taste; getchar (taste); 

kommando text :> kommando auf taste (taste) 
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1620 
1621 
1622 
1623 
+ 

1624 
1625 
1626 
1627 
1628 
1629 
163© 
1631 

1632 Istreservlerte taste 

1633 monitomeldung 
1634 

1635 neueseite 
+ 

1636 

1637 weiterblaettern 

1638 

1639 

1640 

1641 

1642 

1643 

1644 

1645 

1646 

1647 

1648 

1649 

1650 

1651 

1652 

1653 

1654 zurueckblaettern 

1655 

1656 

1657 

1658 

1659 

1660 

1661 

1662 

1663 zeileloeschen 

1664 

1665 

1666 

1667 

1668 

1669 

1670 

1671 



ELIF exit char = ""27"!" 
THEN getchar (taste); 

IF ist reservierte taste 

THQl set busy indicator; 
( *sh« ) 

out (*'FEHLER: + taste + ist reserviert**7'"*) 
ELSE kommando auf taste legen (taste, kommandotext) ; 
kommandotext :* LEAVE editget schleife 

FI 

ELSE LEAVE editget schleife 
FI 
PER . 



ist reservierte taste : pes (res, taste) > 0 . 
monitor raeldung : "gib kommando : ** . 



neue selte : bildanfang := satznr; zeilennr :» 1; neu (akt satznr, 
bild) . 



weiterblaettern : 

INT CX)NST akt bildlaenge := aktuelle bildlaenge; 
IF nicht auf letztem satz 
THEN erster neusatz := satznr; 

IF zeilennr >= akt bildlaenge 

THEN bildanfang INCH akt bildlaenge; neu (akt satznr, bild) 
FI ; 

satznr min (lines (file), bildanfang akt bildlaenge - 1); 

letzter neusatz := satznr; 

tollne (file, satznr); 

s telle DECR verschoben; 

neu (akt satznr, nix); 

zeilennr := satznr - bildanfang + 1; 

IF markiert THEN neu (nix, abschnitt) FI; 

einrueckposition bestiramen 

FI . 



zurueckblaettern : 

IF vorgaenger erlaubt 
THEN IF zeilennr <= 1 

THEN bildanfang := max (1, bildanfang - aktuelle bildlaenge); 
neu (akt satznr, bild) 

FI ; 

nach oben; einrueckposition bestimmen 

FI . 



zeile loeschen : 
IF stelle = 1 
THEN delete record (file); 

erster neusatz := satznr; 

letzter neusatz := bildanfang + bildlaenge - 1; 

neu (nix, abschnitt) 
ELSE zeilen rekombinieren 
FI . 



21/34 



editor paket 



21/34 



Zeile •••• ELAN EUMEL 1.8 10.11.86 ••♦« editor paket 

1672 zeilenrekombinieren |zeilen rekombinieren : 

1673 I IF nicht auf letztem satz 

1674 I THEN aktuellen satz mit blanks auffuellen; 

1675 I delete record (file); 

1676 I nachfolgenden satz lesen; 

1677 I bildsatz CAT nachfol^ender satz ohne fuehrende blanks; 

1678 I write record (file, bildsatz); 

1679 I erster neusatz := satznr; 

168@ I letzter neusatz := bildanfang * bildlaenge - 1; 

1681 I neu (nix, abschnitt) 

1682 ^ I FI . 

1683 I 

1684 aktuellensatzmitblanks | aktuellen satz mit blanks auffuellen : 

1685 I bildsatz AUFFUELLENMIT blank . 

1686 I 

1687 nachfolgendonsatzlesen | nachfolgenden satz lesen : 

1688 I TEXT VAR nachfolgender satz; 

1689 I read record (file, nachfolgender satz) . 

1690 I 

1691 nachfolgendersatzohnef | nachfolgender satz ohne fuehrende blanks : 

1692 I satzrest := subtext (nachfolgender satz, 

1693 I einrueckposition (nachfolgender satz)); satzrest . 

1694 I 

1695 zeileaufsplitten j zeile aufsplitten : 

1696 I nachfolgender satz :«*•"; 

1697 I INT VAR i; 

1698 I FOR i FROM 2 UPTO min (stelle, einrueckposition (bildsatz)) REP 

1699 I nachfolgender satz CAT blank 

1700 I PER; 

1701 I satzrest :» subtext (bildsatz, naechste non blank position); 

1702 I nachfolgender satz CAT satzrest; 

1703 I bildsatz := subtext (bildsatz, 1, stelle - 1); 

1704 I write record (file, bildsatz); 

1705 I down (file); insert record (file); 

1706 I write record (file, nachfolgender satz); up (file) . 

1707 I 

1708 naechstenonblankpositi | naechste non blank position : 

1709 I INT VAR non blank pos := stelle; 

1710 I WHILE (bildsatz SUB non blank pos) - blank REP 

1711 I non blank pos INCR 1 

1712 I PER; non blank pos . 

1713 I 

1714 zumvorigensatz [zum vorigen satz : 

1715 I IF vorgaenger erlaubt THEN vorgaenger; einrueckposition bestimraen 
+ I FI . 

1716 I 

1717 zumfolgendensatz jzum folgenden satz : (• 12.09.85 
+ I -ws- •) 

1718 I IF nachfolger erlaubt THEN nachfolger; einrueckposition bestiramen 

1719 I ELSE col (file, len (file) + 1); neu (nix, 
+ I nix) 

1720 I FI . 

1721 I 



21/35 editor paket 21/35 



Zeile ••»« ELAN EUMEL 1.8 10.11.86 editor paket 



1722 einrueckpositionbestim |einrueckposition bestimmen : (* 27.08.8^ 

I -ws- ») 

1723 I read record (file, akt bildsatz); 

1724 I INT VAR neue einrueckposition := einrueckposition (akt bildsatz); 

1725 I IF akt bildsatz ist leerzeile 

1726 I THEa^ alte einrueckposition := max (stelle, neue einrueckposition) 

1727 I ELSE alte einrueckposition := min (stelle» neue einrueckposition) 

1728 I FI . 

1729 I 

1730 aktbildsatzistleerzeil jakt bildsatz 1st leerzeile : 

1731 I akt bildsatz = OR akt bildsatz . blank . 

1732 I 

1733 zumanfangdesfol^endens jzum anfang des folgenden satzes : 

1734 I IF nachfolger erlaubt THEN nachfolger; stelle := anfang FI . 

1735 I 

1736 nachfolgererlaubt jnachfolger erlaubt : 

1737 I write access COR nicht auf letztem satz . 

1738 j 

1739 eingeruecktmitcr |eingerueckt mit cr : 

1740 I IF NOT nachfolger erlaubt THEN LEAVE eingerueckt rait cr FI; 
+ I («»sh*) 

1741 I read record (file, bildsatz); 

1742 I INT VAR epos := einrueckposition (bildsatz); 

1743 I nachfolger; col (file, 1); 

1744 I IF eof (file) 

1745 I THEN IF LENGTH bildsatz epos 

1746 I THEN stelle := alte einrueckposition 

1747 I ELSE stelle := epos 

1748 I FI 

1749 I ELSE read record (file, bildsatz); 

1750 I stelle := einrueckposition (bildsatz); 

1751 I IF bildsatz ist leerzeile (• 29.08,85 
■»■ I -ws- «) 

1752 I THEN stelle := alte einrueckposition; 

1753 I aktuellen satz rait blanks auffuellen 

1754 I FI 

1755 I FI ; 

1756 I alte einrueckposition :» stelle . 

1757 I 

1758 bildsatzist leerzeile | bildsatz ist leerzeile : 

1759 I bildsatz = OR bildsatz = blank . 

1760 I 

1761 eingeruecktzumfolgende |exiigerueckt zum folgenden satz : 
+ I ( »sh« ) 

1762 I IF NOT nachfolger erlaubt OR NOT write access 

1763 I THEN LEAVE eingerueckt zum folgenden satz 

1764 1 FI; 

1765 I alte einrueckposition merken; 

1766 I naechsten satz holen; 

1767 I neue einrueckposition bestimmen; 

1768 I alte einrueckposition := stelle . 

1769 I 

1770 alteeinrueckpositionme jalte einrueckposition merken : 

1771 I read record (file, bildsatz); 

1772 I epos :» einrueckposition (bildsatz); 
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1773 I auf aufzaehlung pruefen; 

1774 I IF epos > LENGTH bildsatz THEN epos := anfang FI. 

1775 I 

1776 aufaufzaehlungpruefen |auf aufzaehlung pruefen : 

1777 I BOOL CONST aufzaehlung gefunden :« 

1778 I ist aufzaehlung CAND vorher absatzzeile CAND wort folgt; 

1779 I IF aufzaehlung gefunden THEN epos anfang des naechsten wortea 
+ I FI . 

178© I 

1781 istaufzaehlung jist aufzaehlung : 

1782 I INT CONST wortende := pos (bildsatz, blank, epos, epos + 20) - 1; 

1783 I SELECT pos ("-•).:" , bildsatz SUB wortende) OF 

1784 I CASE 1,2 : wortende = epos 

1785 I CASE 3,4 : wortende <= epos + 7 

1786 I CASE 5 : TRUE 

1787 I OTHERWISE: FALSE 

1788 I ENDSELECT . 

1789 1 

1790 vorherabsatzzeile | vorher absatzzeile : 

1791 I IF satznr = 1 

1792 I THEN TRUE 

1793 I ELSE up (file); 

1794 I INT CONST vorige satzlaenge ;= len (file); 

1795 I BOOL CONST vorher war absatzzeile := 

1796 I subtext (file, vorige satzlaenge, vorige satzlaenge) * blank; 

1797 I down (file); vorher war absatzzeile 

1798 I FI . 

1799 I 

1800 wortfolgt I wort folgt : 

1801 j INT CONST anfang des naechsten wortes := 

1802 I pos (bildsatz, ****33***', ""254"", wortende + 1); 
1603 I anfang des naechsten wortes > wortende . 

1804 I 

1805 naechstensatzholen {naechsten satz holen : 

1806 I nachfolger; col (file, 1); 

1807 I IF eof (file) 

1808 I THEN bildsatz := "" 

1809 I ELSE IF neue zeile einfuegen erforderlich 

1810 I THEN insert record (file); bildsatz := ""; 

1811 I letzter neusatz := bildanfang -»■ bildlaenge - 1 

1812 I ELSE read record (file, bildsatz); 

1813 I letzter neusatz ;= satznr; 

1814 I ggf trennungen zurueckwandeln und umbruch indikator 
+ I einfuegen 

1815 I FI ; 

1816 I erster neusatz :^ satznr; 

1817 I neu (nix, abschnitt) 

1818 I FI . 

1819 I 

1820 neuezeileelnfuegenerfo |neue zeile einfuegen erforderlich : 

1821 I BOOL CONST war absatz :> war absatzzeile; 

1822 I war absatz COR neuer satz ist zu lang . 

1823 I 
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1824 warabsatzzeile |war absatzzeile : 

1825 j INT VAR wl := pos ( kommando , up backer, kommando zelger) ; 

1826 I wl = 0 COR (kommando SUB (wl - D) « blank . 

1827 I 

1828 neuorsatzistzulang jneuer satz ist zu lang : laenge des neuen satzes >= limit . 

1829 I 

1830 laengedesneuensatzes j laenge des neuen satzes : 

1831 I IF len (file) > 0 

1832 I THEN len (file) + wl 

1833 I ELSE wl + epos 

1834 I FI . 

1835 I 

1836 upbackcr |up backer : ""3''"20"" . 

1837 I 

1838 ggftrennungenzurueckwa |ggf trennungen zurueckwandeln und umbruch indikator einfuegen : 

1839 I LET trenn k = *'**220''", 

1840 I trenn strich = ""221*'"; 

1841 I TEXT VAR umbruch indikator; 

1842 I IF letztes zeiehen ist trenn strich 

1843 I THEN entferne trenn strich; 

1844 I IF letztes zeiehen = trenn k 

1845 I THEN wandle trenn k um 

1846 I FI ; 

1847 I umbruch indikator := up backer 

1848 I ELIF letztes umgebrochenes zeiehen ist kanji 
1649 I THEN umbruch indikator := up backer 

1850 I ELSE umbruch indikator blank ■•■ up betcker 

1851 I FI ; 

1852 j change (kommando, wl, wl-t-1, umbruch indikator) . 

1853 I 

1854 letztesufflgebrochenesze | letztes umgebrochenes zeiehen ist kanJi : within kanJi (kommando, 
+ I wl-1) . 

1855 I 

1856 letzteszeiehenisttrenn (letztes zeiehen ist trenn strich : 

1857 I TEXT CONST last char ;= letztes zeiehen; 

1858 I last char = trenn strich COR 

1859 I last char = "-" CAND wl > 2 CAND (kommando SUB (wl-2)) <> blank . 

1860 I 

1861 letzteszeiehen j letztes zeiehen : kommando SUB (wl-1) . 

1862 entfernetrennstrich j entferne trenn strich : delete char (kommando, wl-1); wl DECR 1 . 

1863 wandletrennkum [wandle trenn k um : replace (kommando, wl-1, "e") . 

1864 loesehe indikator jloesche indikator : delete char (koimando, wl) . 

1865 I 

1866 neueeinrueckpositionbe |neue einrueckposition bestimmen : 

1867 I IF aufzaehlung gefunden CANS bildsatz ist leerzeile 

1868 I THEN stelle :» epos 

1869 I ELIF NOT bildsatz ist leerzeile 

1870 j THEN stelle einrueckposition (bildsatz) 

1871 I ELIF war absatz COR auf letztem satz 

1872 I THEN stelle := epos 

1873 I ELSE down (file); read record (file, nachfolgender satz); 
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1874 
1875 
1876 
1877 
1878 
+ 

1879 
1880 
1881 

1882 aufletztemsatz 
1883 

1884 isteinfuegenderabernic 

1885 

1886 

1887 

1888 anzahlderstz 
1889 
+ 

1890 
+ 

1891 
1892 
+ 

1893 
1894 

1895 markiertesvorsichtiglo 

1896 

1897 

1898 

1899 

1900 

1901 

1902 

1903 

1904 nurlrasatzmarklert 
1905 

1906 behandleeinensatz 

1907 

1908 

1909 

1910 

1911 

1912 

1913 

1914 

1915 

1916 

1917 

1918 

1919 

1920 

1921 

1922 

1923 

1924 



up (file); stelle := einrueckposition ( nachf olgender satz) 

FI ; 

IF ist elnfuegender aber nicht induzierter umbruch 
THEN loesche indikator; 

umbruchstelle := stelle + wl - kommando zeiger - anzahl der 
stz; 

umbruchvorschoben :« 0 

FI . 



lauf letztem satz : NOT nicht auf letztem satz . 



ist einfuegender aber nicht induzierter umbruch : 
wl := pos (konmiando, backer, konniando zeiger); 
wl > 0 CAND (kommando SUB (wl - 1)) <> up char . 



anzahl der stz : 

TEXT CONST umgebrochener anfang :* subtext (kommando, kommando 
zeiger, wl-1); 

INT VAR anz := 0, anf := pos (umgebrochener anfang, ""i**", ""si"", 

1); 

WHILE anf > 0 REP 
anz INCR 1; anf := pos (umgebrochener anfang, ""i"**, *'"3i'**', anf 

+ 1) 
PER; anz . 



markiertes vorsichtig loeschen : 
IF write access CAND markiert 
THEN clear removed (file); 

IF nur im satz markiert 
THEN behandle einen satz 
ELSE behandle mehrere saetze 
FI 

FI . 



nur im satz markiert : line no (file) = bildmarke . 



behandle einen satz : 
insert record (file); 

satzrest := subtext (bildsatz, marke, stelle - 1); 
write record (file, satzrest); 
remove (file, 1); 

change (bildsatz, marke, stelle - 1, ****); 
stelle := marke; 

marke 0; bildmarke := 0; feldmarke :> 0; 

markiert FALSE; mark (file, 0, 0); 

konstanten neu berechnen; 

IF bildsatz = "** 

THEN delete record (file); 

erster neusatz := satznr; 

letzter neusatz := bildanfang + bildlaenge - 1; 
neu (nix, abschnitt) 
ELSE write record (file, bildsatz); 
neu (nix, bildzeile) 

FI . 
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1925 behandlemehreresaetze Ibehandle mehrere saetze : 

1926 I erster neusatz :» bildmarke; 

1927 I letzter neusatz := bildanfang * blldlaenge - 1; 

1928 I zeile an aktueller stelle auftrennen; 

1929 I ersten markierten satz an markieranfang aufspalten; 

1930 I markierten bereich entfernen; 

1931 I bild anpassen . 

1932 I 

1933 zeileanaktue Hers telle | zeile an aktueller stelle auftrennen : 

1934 I INT VAR markierte saetze := line no (file) - bildmarke + 1; 

1935 I IF nicht am ende der zeile 

1936 I THEN IF nicht am anfang der zeile 

1937 I THEN zeile aufsplitten 

1936 I ELSE up (file); markierte saetze DECR 1 

1939 I FI 

1940 I FI . 

1941 I 

1942 nichtamanfangderzeile | nicht am anfang der zeile : stelle > 1 . 

1943 nichtamendeder zeile | nicht am ende der zeile : stelle <= LENGTH bildsatz . 

1944 I 

1945 erstenmarkiertensatzan | ersten markierten satz an markieranfang aufspalten : 

1946 I to line (file, line no (file) - (markierte saetze - 1)); 

1947 I read record (file, bildsatz); 

1948 I stelle ;= feldmarke; 

1949 I IF nicht am anfang der zeile 

1950 I THEN IF nicht am ende der zeile 

1951 I THEN zeile aufsplitten 

1952 I ELSE markierte saetze DECR 1 

1953 I FI ; 

1954 I to line (file, line no (file) + markierte saetze) 

1955 I ELSE to line (file, line no (file) + markierte saetze - 1) 

1956 I FI ; 

1957 I read record (file, bildsatz) . 

1958 I 

1959 markiertenbereichentfe | markierten bereich entfernen : 

1960 I zeilen nr := line no (file) - markierte saetze - bildanfang + 2; 

1961 I remove (file, markierte saetze); 

1962 I marke := 0; bildmarke := 0; feldmarke := 0; 

1963 I markiert := FALSE; mark (file, 0, 0); 

1964 I konstanten neu berechnen; 

1965 I stelle := 1 . 

1966 1 

1967 bildanpassen jbild anpassen : 

1968 I satz nr := line no (file); 

1969 I IF zeilen nr <» 1 

1970 I THEN bildanfang := line no (file); zeilen nr := 1; 

1971 I neu (akt satznr, bild) 

1972 I ELSE neu (akt satznr, abschnltt) 

1973 I FI . 

1974 1 

1975 vorsichtiggeloeschtese jvorsichtig geloeschtes einfuegen : 

1976 I IF NOT write access OR removed lines (file) = 0 

1977 I THEN LEAVE vorsichtig geloeschtes einfuegen 

1978 I FI ; 

1979 I IF nur ein satz 



21/40 



editor paket 



21/40 



Zeile ELAN EUMEL 1.8 10.11.86 editor poket 



1960 I THEN In aktuellen satz elnfuegen 

1981 I ELSE aktuellen satz aufbrechen und elnfuegen 

1982 I FI . 

1983 I 

1984 nureinsatz |nur ein satz : removed lines (file) = 1 . 

1985 I 

1986 inaktuellensatzeinfueg jin aktuellen satz elnfuegen ; 

1987 I reinsert (file); 

1988 I read record (file, nachfolgender satz); 

1989 I delete record (file); 

1990 I TEXT VAR t := bildsatz; 

1991 I bildsatz := subtext (t, 1, stelle - 1); 

1992 I aktuellen satz mit blanks auffuellen; 
+ I ( •sh* ) 

1993 I bildsatz CAT nachfolgender satz; 

1994 I satzrest := subtext (t, stelle); 

1995 I bildsatz CAT satzrest; 

1996 I write record (file, bildsatz); 

1997 I stelle INCH LENGTH nachfolgender satz; 

1998 I neu (nix, bildzeile) . 

1999 I 

2000 aktuellensatzaufbreche | aktuellen satz aufbrechen und elnfuegen : 

2001 I INT CONST alter bildanfang := blldanfang; 

2002 I old lineno := satznr; 

2003 I IF stelle = 1 

2004 I THEN reinsert (file); 

2005 I read record (file, bildsatz) 

2006 I ELIF stelle > LENGTH bildsatz 

2007 I THEN down (file); 

2008 I reinsert (file); 

2009 I read record (file, bildsatz) 

2010 I ELSE INT VAR von stelle; 

2011 I WHILE (bildsatz SUB von) = blank REP von INCR 1 PER; 

2012 I satzrest := subtext (bildsatz, von, LENGTH bildsatz); 

2013 1 INT VAR bis := stelle - 1; 

2014 I WHILE (bildsatz SUB bis) = blank REP bis DECR 1 PER; 

2015 I bildsatz subtext (bildsatz, 1, bis); 

2016 I write record (file, bildsatz); 

2017 i down (file); 

2018 I reinsert (file); 

2019 I read record (file, bildsatz); 

2020 1 nachfolgender satz :« einrueckposition (bildsatz) • blank; 

2021 1 nachfolgender satz CAT satzrest; 

2022 j down (file); insert record (file); 

2023 I write record (file, nachfolgender satz); up (file) 

2024 I FI ; 

2025 I stelle max (1, LENGTH bildsatz); (» 22.06.84 
+ 1 -bk- •) 

2026 1 satz nr :<i line no (file); 

2027 I zeilennr INCR satznr - old lineno; 

2028 I zeilennr :» min (zeilennr, aktuelle bildlaenge); 

2029 I bildanfang := satznr - zeilennr + 1; 

2030 I IF bildanfang veraendert 

2031 1 THEN abschnitt neu (bildanfang, 9999) 

2032 I ELSE abschnitt neu (old lineno, 9999) 

2033 I FI ; 

2034 I neu (akt satznr, nix). 

2035 I 

21/41 editor paket 21/41 



Zeile *•♦• ELAN EUMEL 1.8 10.11.86 »••» editor paket 

2036 blldanfangveraendert |blldanfang vera^ndert : bildanfang <> alter bildanfang . 

2037 I 

2036 lernmodusumschalten jlernniodus umschalten : 

2039 I learn segment in ueberschrift eintragen; neu (ueberschrift, nix) . 

2040 I 

2041 learnsegmentlnuebersch | learn segment in ueberschrift eintragen : 

2042 I replace (ueberschrift text, feldlaenge - 19, learn segment) . 

2043 I 

2044 learnsegment | learn segment : 

2045 I IF lernmodus THEN "LEARN" ELSE " " FI . 

2046 I 

2047 markierungumschalten |markierung umschalten : 

2048 I IF markiert THEN roarkierung ausschalten ELSE markierung 
+ I einschalten FI . 

2049 I 

2050 markierungeinschalten j markierung einschalten : 

2051 I bildmarke := satznr; feldmarke := marke; markiert := TRUE; 

2052 I mark (file, bildmarke, feldmarke); 

2053 I neu (nix, bildzeile) . 

2054 I 

2055 markierungausschalten | markierung ausschalten : 

2056 I erster neusatz := max (bildmarke, bildanfang); 

2057 I letzter neusatz := satznr; 

2058 I bildmarke := 0; feldmarke := 0; markiert := FALSE; 

2059 1 mark (file, 0, 0); 

2060 I IF erster neusatz = letzter neusatz 

2061 I THEN neu (nix, bildzeile) 

2062 I ELSE neu (nix, abschnitt) 

2063 I FI . 

2064 I END PROC bildeditor; 

2065 I 

2066 neu |PROC neu (INT CX)NST ue bereich, b bereich) : 

2067 I ueberschriftbereich := max (ueberschriftbereich, ue bereich); 

2068 I bildbereich := max (bildbereich, b bereich) 

2069 I END PROC neu; 

2070 I 

2071 I 

2072 nachoben | PR(X nach oben : 

2073 I letzter neusatz := satznr; 

2074 I satznr := max (bildanfang, bildmarke); 

2075 I toline (file, satznr); 

2076 I stelle DECTR verschoben; 

2077 I zeilennr := satznr - bildanfang ■*■ 1; 

2078 I erster neusatz := satznr; 

2079 I IF markiert 

2080 I THEN neu (akt satznr, abschnitt) 

2081 I ELSE neu (akt satznr, nix) 

2082 I FI 

2083 lEND PROC nach oben; 
2084 
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2085 aktuellebildlaenge |INT PROC aktuelle bildlaenge : 

2086 I IF stelle - stelle am anfang < kurze feldlaenge 

2087 I AND feldlaenge > 0 

2088 I THEN bildlaenge 
+ I (•wk») 

2089 I ELSE kurze bildlaenge 

2090 I n 

2091 I ENS PROC aktuelle bildlaenge; 

2092 I 

2093 vorgaenger | PROC vorgaenger : 

2094 I up (file); satznr DECR 1; 

2095 I marke :« 0; stelle DECR verschoben; 

2096 I IF zeilennr = 1 

2097 j THEN bildanfang DECR 1; neu (ueberschrift, bild) 

2098 I ELSE zeilennr DECR 1; neu (akt satznr, nix); 
+ I («»sh») 

2099 I IF markiert THEN neu (nix, bildzeile) FI 

2100 I FI 

2101 I END PROC vorgaenger; 

2102 I 

2103 nachfolger |PROC nachfolger : 

2104 I down (file); satznr INCR 1; 

2105 I stelle DECR verschoben; 

2106 I IF zeilennr = aktuelle bildlaenge 

2107 I THEN bildanfang INCR 1; 

2108 I IF rollup erlaubt 

2109 I THEN rollup 

2110 I ELSE neu ( ueberschrif t , bild) 

2111 I FI 

2112 I ELSE neu (akt satznr, nix); zeilennr INCR 1 
+ I (♦sh«) 

2113 I FI ; 

2114 I IF markiert THEN neu (nix, bildzeile) FI . 

2115 I 

2116 rolluperlaubt j rollup erlaubt : 

2117 I kurze bildlaenge = maxlaenge AND kurze feldlaenge = maxbreite . 

2118 I 

2119 rollup I rollup : 

2120 I out (down char); 

2121 I IF bildzeichen = inscr 

2122 I THEN neu (ueberschrift, nix) 

2123 I ELIF is cr or down CAND (write access OCR nicht auf letztem satz) 
+ I (•sh*) 

2124 I THEN neu (nix, bildzeile) 

2125 I ELSE neu (ueberschrift, bildzeile) 

2126 I FI . 

2127 I 

2128 iscrordown jis cr or down : 

2129 I IF kommando - THEN kommando := inchety FI; 

2130 I kommando char = down char COR kommando char > cr . 

2131 I 

2132 kommandochar Ikomnando char : kommando SUB kommando zeiger . 

2133 I 
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2134 nichtaufletztemsatz jnicht auf letztem satz : line no (file) < lines (file) . 

2135 I END PROC nachfol^er; 

2136 I 

2137 nextincharetyis |BOOL PROC next incharety is (TEXT CONST muster) : 

2138 I INT CONST klen := LENGTH kommando - kommando zeiger + 1, 

2139 I mien := LENGTH muster; 

2140 1 INT VAR i; FOR i FROM 1 UPTO mien - klen REP kommando CAT inchety 
+ I PER; 

2141 I subtext (kommando, kommando zeiger, kommando zeiger mien - 1) - 
+ I muster 

2142 I END PROC next incharety is; 

2143 I 

2144 quitlast |PROC quit last: (* 22.06.84 

+ I -bk- •) 

2145 I IF actual editor > 0 AND actual editor < max used editor 

2146 I THEN verlasse alle groesseren editoren 

2147 I FI . 

2148 I 

2149 verlasseallegroesseren | verlasse alle groesseren editoren : 

2150 I open editor (actual editor + 1); quit . 

2151 I END PROC quit last; 

2152 I 

2153 quit I PROC quit : 

2154 I IF actual editor > 0 THEN verlasse aktuellen editor FI . 

2155 I 

2156 verlasseaktuellenedito | verlasse aktuellen editor : 

2157 I disable stop; 

2158 I INT CONST aktueller editor := actual editor; 

2159 I in innersten editor gehen; 

2160 I REP 

2161 I IF zeileneinfuegen THEN hop rubin simulieren FI; 

2162 I ggf bildschirmdarstellung korrigieren; 

2163 I innersten editor schliessen 

2164 I UNTIL aktueller editor > max used editor PER; 

2165 I actual editor :» vaax used editor . 

2166 I 

2167 ininnersteneditorgehen |in innersten editor gehen : open editor (max used editor) . 

2168 I 

2169 hoprubinsimulieren jhop rubin simulieren : 

2170 I zeileneinfuegen := FALSE; 

2171 I leere zeilen am dateiende loeschen; 
+ I (•sh*) 

2172 I ggf bildschirmdarstellung korrigieren; 

2173 I logisches eof loeschen . 

2174 I 

2175 innersteneditorschlies [innersten editor schliessen : 

2176 j max used editor DECR 1; 

2177 I IF max used editor > 0 

2178 j THEN open editor (max used editor); 

2179 I bildelnschraenkung aufheben 

2180 I FI . 
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2181 I 

2182 logischeseofloeschen |logisches eof loeschen : 

2183 I col (file» stelle); set range (file, old range) . 

2184 I 

2185 leerezeilenamdateiende |leere zeilen am dateiende loeschen : (• 15.08.85 
+ I -ws- •) 

2186 I satz nr := line no (file) ; 

2187 I to line (file, lines (file)) ; 

2188 I WHILE lines (file) > 1 AND bildsatz ist leerzeile REP 

2189 j delete record (file); 

2190 I to line (file, lines (file)) 

2191 I PER; 

2192 I toline (file, satznr) . 

2193 I 

2194 bildsatzistleerzeile j bildsatz ist leerzeile : 

2195 I TEXT VAR bildsatz; 

2196 I read record (file, bildsatz); 

2197 I ist leerzeile . 

2198 I 

2199 Istleerzeile jlst leerzeile : 

2200 1 bildsatz = *"* OR bildsatz . blank . 

2201 I 

2202 ggfbildschirmdarstellu |ggf bildschirmdarstellung korrigieren : 

2203 I satz nr DECR 1; (• fiir 

I Bildschinnkorrektur ») 

2204 I IF satznr > lines (file) 

2205 I THEN zeilen nr DECR satz nr - lines (file); 

2206 I satz nr := lines (file); 

2207 I dateizustand retten 

2208 I n . 

2209 I 

2210 bildeinschraenkungaufh jbildeinschraenkung aufheben : 

2211 I laenge feldlaenge; 

2212 I kurze feldlaenge feldlaenge; 

2213 I kurze bildlaenge := bildlaenge; 

2214 I neu (nix, bild) . 

2215 I END PROC quit; 

2216 I 

2217 nichtsneu |PROC nichts neu : neu (nix, nix) END PROC nichts nm 

2218 I 

2219 satznrneu |PROC satznr neu : neu (akt satznr, nix) END PROC satznr nm 

2220 I 

2221 ueberschriftneu |PROC ueberschrift neu : neu (ueberschrift, nix) END PROC 

-»■ I ueberschrift neu; 

2222 I 

2223 zeileneu |PROC zeile neu : 

2224 I INT CONST zeile := line no (file); 

2225 I abschnitt neu (zeile, zeile) 
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2226 I END PROC zeile neu; 

2227 I 

2228 abschnittneu |PROC abschnitt neu (INT CONST von satznr, bis satznr) : 

2229 I IF von satznr <= bis satznr 

2230 I THEN erster neusatz := min (erster neusatz, von satznr); 

2231 I letzter neusatz := max (letzter neusatz, bis satznr); 

2232 I neu (nix, abschnitt) 

2233 I ELSE abschnitt neu (bis satznr, von satznr) 

2234 I FI 

2235 I END PROC abschnitt neu; 

2236 I 

2237 bildabschnittneu |PROC bildabschnitt neu (INT CONST von zeile, bis zeile) : 

+ I ( *sh» ) 

2238 I IF von zeile <= bis zeile 

2239 1 THEN erster neusatz := max (1, von zeile + bildanfang - 1); 

2240 I letzter neusatz := min (bildlaenge, bis zeile •»- bildanfang - 
+ ID; 

2241 I IF von zeile < 1 

2242 I THEN neu (ueberschrift, abschnitt) 

2243 I ELSE neu (nix , abschnitt) 

2244 I FI 

2245 I ELSE bildabschnitt neu (bis zeile, von zeile) 

2246 I FI 

2247 I END PROC bildabschnitt neu; 

2248 I 

2249 bildneu |PROC bild neu : neu (nix, bild) END PROC bild neu; 

+ I (»sh») 

2250 I 

2251 bildneu |PROC bild neu (FILE VAR f) : 

2252 I INT CONST editor no := abs (editinfo (f)) DIV 256; 

2253 I IF editor no > 0 AND editor no <= max used editor 

2254 I THEN IF editor no = actual editor 

2255 I THEN bild neu 

2256 I ELSE editstack (editor no) .bildstatus.bildbereich := bild 

2257 I FI 

2258 I FI 

2259 I END PROC bild neu; 

2260 I 

2261 allesneu |PROC alles neu : 

2262 I neu (ueberschrift, bild); 

2263 I INT VAR i; 

2264 I FOR i FROM 1 UPTO max used editor REP 

2265 I editstack (i) .bildstatus.bildbereich :» bild; 

2266 I editstack ( i) .bildstatus.ueberschriftbereich := ueberschrift 

2267 I PER 

2268 I END PROC alles neu; 

2269 I 

2270 satznrzeigen jPROC satznr zeigen : 

2271 I out (satznr pre); out (text (text (lineno (file)), 4)) 

2272 I END PROC satznr zeigen; 
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2273 



2274 
2275 
2276 
2277 
2278 
-2279 
2280 
2281 
2282 
2283 
2284 



2285 
2286 
2287 
2288 
2289 
2290 
2291 

2292 
2293 
2294 
2295 
2296 
2297 
2298 
2299 
2300 
2301 
2302 
2303 
2304 
2305 
2306 



2307 
2308 
+ 

2309 
2310 
2311 
2312 
2313 
2314 
+ 

2315 
+ 

2316 
2317 
2318 
2319 
2320 
2321 
2322 
2323 
2324 



ueberschri f tze ige n 



fensterzeigen 



bildausgeben 



PROC ueberschrift zeigen : 
SELECT ueberschri ftbereich OF 



CASE akt satznr 



CASE ueberschrift 



CASE fehlermeldung 



satznr zeigen; 
ueberschriftbereich := nix 
ueberschrift schreiben; 
ueberschriftbereich := nix 
fehlermeldung schreiben; 
ueberschriftbereich := ueberschrift 



END SELECT 
END PROC ueberschrift zeigen; 



PROC fenster zeigen : 
SELECT bildbereich OF 
CASE bildzeile : 

zeile := bildrand + zeilennr; 

IF line no (file) > lines (file) 

THEN feldout ("**, stelle) 

ELSE exec (PROC (TEXT CONST, INT CONST) feldout, file, 
stelle) 

FX 

CASE abschnitt : 

bild ausgeben 
CASE bild : 

erster neusatz : = 1 ; 

letzter neusatz := 9999; 

bild ausgeben 
OTHERWISE : 

LEAVE fenster zeigen 
END SELECT; 

erster neusatz := 9999; 
letzter neusatz := 0; 
bildbereich := nix 
END PROC fenster zeigen ; 



PROC bild ausgeben : 

BOOL CONST schreiben ist ganz einfach := NOT markiert AND 

verschoben = 0; 
INT CONST save marke := marke, 

save verschoben := verschoben, 

save laenge := laenge, 

act lineno := lineno (file), 

von := max (1, erster neusatz - bildanfang +1); 



INT VAR bis := min (letzter neusatz - bildanfang + 1, 

0 THEN bis := min (bis, kurze bildlaenge) 



bild laenge) ; 
IF kurze feldlaenge 
FI; 

IF von > bis THEN LEAVE bild ausgeben FI; 
verschoben := 0; 
IF markiert 

THEN IF mark lineno (file) < bildanfang + von - 1 
THEN marke := anfang 
ELSE marke := 0 
FI 

FI ; 

abschnitt loeschen und neuschreiben; 
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2325 I to line (file, act lineno); 

2326 I laenge := save laenge; 

2327 I verschoben := save verschoben; 

2328 I marke := save marke . 

2329 I 

2330 markiert |markiert : maxk lineno (file) > 0 . 

2331 I 

2332 abschnittloeschenundne jabschnitt loeschen und neuschreiben : 

2333 I abschnitt loeschen; 

2334 I INT VAR line number := bildanfang + von - 1; 

2335 I to line (file, line number); 

2336 I abschnitt schreiben . 

2337 I 

2338 abschnittloeschen | abschnitt loeschen : 

2339 I cursor (rand + 1, bildrand + von); 

2340 I IF bildrest darf koraplett geloescht werden 

2341 I THEN out (clear eop) 

2342 I ELSE zeilenweise loeschen 

2343 I FI . 

2344 I 

2345 bildrestdarfkomplettge j bildrest darf komplett geloescht werden : 

2346 I bis = maxlaenge AND kurze bildlaenge = maxlaenge 

2347 I AND kurze feldlaenge > maxbreite . 

2348 I 

2349 zeilenweiseloeschen {zeilenweise loeschen : 

2350 I INT VAR i; 

2351 I FOR i FROM von UPTO bis REP 

2352 I check for interrupt; 

2353 I feldlaenge einstellen; 

2354 I feldrest loeschen; 

2355 I IF i < bis THEN out (down char) FI 

2356 I PER . 

2357 1 

2358 feldlaengeeinstellen j feldlaenge einstellen : 

2359 I IF ganze zeile sichtbar 

2360 I THEN laenge := feldlaenge 

2361 I ELSE laenge := kurze feldlaenge 

2362 I FI . 

2363 I 

2364 ganzezeilesichtbar j ganze zeile sichtbar : i <= kurze bildlaenge . 

2365 I 

2366 abschnittschreiben [abschnitt schreiben : 

2367 I INT CONST last line :- lines (file); 

2368 I FOR i FROM von UPTO bis 

2369 I WHILE line number <= last line REP 

2370 I check for interrupt; 

2371 I feldlaenge einstellen; 

2372 I zeile schreiben; 

2373 I down (file); 

2374 I line number INCR 1 

2375 I PER . 

2376 I 
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2377 checkforinterrupt | check for interrupt : 

2378 1 kommando CAT inchety; 

2379 I IF kommando <> 

238© I THEN IF zeilen nr = 1 CAND up command CAND vorgaenger erlaubt 

2381 I THEN LEAVE abschnitt loeschen und neuschreiben 

2382 I ELIF zeilen nr = bildlaenge CAND down command CAND nicht 
+ I letzter satz 

2363 I THEN LEAVE abschnitt loeschen und neuschreiben 

2384 I FI 

2385 I FI . 

2386 I 

2387 vorgaengererlaubt | vorgaenger erlaubt : 

2388 I satznr > max (1, bildmarke) . 

2389 I 

2390 upcommand |up command : next Incharety is ('***3'**') COR next incharety is 

2391 I 

2392 downcommand |down command : 

2393 I next incharety is (""10"") CAND bildlaenge < maxlaenge 

2394 I COR next incharety is (""l""!©"") . 

2395 I 

2396 nichtletztersatz j nicht . letzter satz : act lineno < lines (file) . 

2397 I 

2398 zeileschreiben j zeile schreiben : 

2399 I zeile := bildrand + i; 

24©© I IF schreiben ist ganz einfach 

24©1 I THEN exec (PROC (TEXT CONST, INT CONST) simple feldout, file, 0) 

2402 I ELSE zeile kompliziert schreiben 

24©3 I FI ; 

24©4 I IF line number = old lineno THEN old line update := FALSE FI . 

24©5 I 

24©6 zeilekompliziertschrei j zeile kompliziert schreiben : 

24©7 I IF line number = mark lineno (file) THEN marke :» mark col 

+ I (file) FI; 

24©8 I IF line number = act lineno 

2409 I THEN verschoben := save verschoben; 

2410 I exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle); 

2411 I verschoben := 0; marke := 0 

2412 I ELSE exec (PROC (TEXT CONST. INT CONST) feldout, file, 0); 

2413 I IF line number = mark lineno (file) THEN marke :« anfang FI 

2414 I FI . 

2415 I END PROC bild ausgeben; 

2416 I 

2417 bildzeigen |PROC bild zeigen : 

+ I (* wk •) 

2418 I 

2419 I dateizustand holen ; 

2420 I ueberschrift zeigen ; 

2421 I bildausgabe steuern ; 

2422 I bild neu ; 

2423 I . fenster zeigen ; 

2424 I oldline no satznr ; 

2425 I old line update := FALSE ; 

2426 old satz "" ; 
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2427 I old zeilennr := satznr - bildanfang + 1 ; 

2428 I dateizustand retten . 

2429 I 

2430 lENDPROC bild zeigen ; 

2431 I 

2432 ueberschriftinitialisi ...|PROC ueberschrift initialisieren : 
+ I ("sh*) 

2433 I satznr pre := 

2434 I cursor pos + code (bildrand - 1) + code (rand + feldlaenge - 
^ I 6); 

2435 I ueberschrift pre := 

2436 I cursor pos + code (bildrand - 1) + code (rand) + mark anf; 

2437 I ueberschrift text := INT VAR i; 

2436 I FOR i FROM 16 UPTO feldlaenge REP ueberschrift text CAT PER; 

2439 I ueberschrift post := blank + mark end + "Zeile " + mark anf; 

2440 I ueberschrift post CAT blank + mark end + " "; 

2441 I filename := headline (file); 

2442 I filename := subtext (filename, 1, feldlaenge - 24); 

2443 I insert char (filename, blank, 1); filename CAT blank; 

2444 I replace (ueberschrift text, filenamepos, filename); 

2445 I rubin segment in ueberschrift eintragen; 

2446 I margin segment in ueberschrift eintragen; 

2447 I rest segment in ueberschrift eintragen; 

2448 I learn segment in ueberschrift eintragen . 

2449 I 

2450 filenamepos | filenamepos : (LENGTH ueberschrift text - LENGTH filename + 3) 
+ I DIV 2 . 

2451 msurkanf jmark anf : begin mark + mark ausglelch. 

2452 markend jmark end end mark mark ausglelch. 

2453 markausgleich jmark ausglelch : (1 - sign (max (mark size, 0))) » blank . 

2454 I 

2455 rubinsegmentinuebersch j rubin segment in ueberschrift eintragen : 

2456 I replace (ueberschrift text, 9, rubin segment) . 

2457 j 

2458 rubinsegment | rubin segment : 

2459 I IF einfuegen THEN "RUBIN** ELSE " " FI . 

2460 I 

2461 marginsegmentinuebersc | margin segment in ueberschrift eintragen : 

2462 I replace (ueberschrift text, 2, margin segment) . 

2463 I 

2464 marglnsegment {margin segment : 

2465 I IF anfang <= 1 

2466 I THEN " " 

2467 I ELSE TEXT VAR margin text := "M" + text (anfang); 

2468 I (6 - LENGTH margin text) • + margin text 

2469 I FI . 

2470 I 

2471 restsegmentinueberschr jrest segment in ueberschrift eintragen : 

2472 I replace (ueberschrift text, feldlaenge - 25, rest segment) . 
2473 
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2474 restsegment |rest segment : 

2475 I IF zeileneinfuegen THEN **RESr ELSE . 

2476 I 

2477 learnsegmentinuebersch | learn segment in ueberschrift eintragen : 

2478 I replace (ueberschrift text, feldlaenge - 19, learn segment) . 

2479 1 

2480 learnsegment | learn segment : 

2481 I IF lernmodus THEN "LEARN** ELSE " FI . 

2482 I 

2483 I END PROC ueberschrift initialisieren; 

2484 I 

2485 ueberschriftschreiben ....|PROC ueberschrift schreiben : 

2486 I replace (uetserschrift post, satznr pos, text (text (lineno 
+ I (file)), 4)); 

2487 I out (ueberschrift pre); out (ueberschrift text); out (ueberschrift 
+ I post); 

2488 I get Ubs (file, tab); 

2489 I IF pos (tab, dach) > 0 

2490 I THEN out (ueberschrift pre); 

2491 I out subtext (tab, anfang + 1, anfang + feldlaenge - 1); 

2492 I cursor (rand + 1 + feldlaenge, bildrand); out (end mark) 

2493 I FI . 

2494 I 

2495 satznrpos j satznr pos : IF mark size > 0 THEN 9 ELSE 10 FI . 
+ I ( »sh« ) 

2496 I END PRCXJ ueberschrift schreiben; 

2497 I 

2498 fehlermeldungschreiben ...|PROC fehlermeldung schreiben : 

2499 I ueberschrift schreiben; 

2500 I out (ueberschrift pre); 

2501 I out ("FEHLER: "); 

2502 I out subtext (fehlertext, 1, feldlaenge - 21); 

2503 I out (blank); 

2504 I out (piep); 

2505 I cursor (rand + 1 + feldlaenge, bildrand); out (end mark) 

2506 I END PROC fehlermeldung schreiben; 

2507 I 

2508 setbusyindicator |PRCXJ set busy indicator : 

2509 I cursor (rand + 2, bildrand) 

2510 I END PRCX: set busy indicator; 

2511 I 

2512 kommandoanalysieren |PROC kommando analysieren (TEXT CONST taste, 

2513 I PROC (TEXT CONST) kommando interpreter) : 

2514 I disable stop; 

2515 I bildausgabe normieren; 

2516 I zustand in datei sichern; 

2517 I editfile modus setzen; 

2518 I kommando interpreter (taste); 

2519 I editfile modus zuruecksetzen; 

2520 I IF actual editor <= 0 THEN LEAVE kommando analysieren FI; 

2521 I absatz ausgleich := 2; 
+ I ( •sh* ) 
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2522 I konstanten neu berechnen; 

2523 I neues bild bei undefinierter benutzeraktion; 

2524 I evtl fehler behandeln; 

2525 I zustand aus date! holen; 

2526 I bildausgabe steuern . 

2527 I 

2528 editfilemodussetzen jeditfile modus setzen : 

2529 I BOOL VAR alter editget modus := editget modus ; 

2530 j editget modus := FALSE . 

2531 I 

2532 editfilemoduszurueckse jeditfile modus zuruecksetzen : 

2533 I editget modus := alter editget modus . 

2534 I 

2535 evtlfehlerbehandeln jevtl fehler behandeln : 

2536 I IF is error 

2537 I THEN fehlertext := errormessage; 

2538 1 IF fehlertext <> THEN neu (fehlerraeldung, nix) FI; 

2539 I clear error 

2540 I ELSE fehlertext := 

2541 I FI . 

2542 I 

2543 zustandindateisichern | zustand in date! slchern : 

2544 I old zeilennr := zeilennr; 

2545 I old mark llneno := bildmarke; 

2546 I dateizustand retten . 

2547 I 

2548 zustandausdateiholen | zustand aus datei holen : 

2549 I dateizustand holen; 

2550 I IF letzer editor auf dieser datei <> actual editor 

2551 I THEN zurueck auf alte position; neu (ueberschrift, bild) 

2552 I FI . 

2553 I 

2554 zurueckaufalteposition j zurueck auf alte position : 

2555 I to line (file, old llneno); 

2556 I col (file, alte stelle); 

2557 I IF fllesstext 

2558 I THEN editinfo (file, old zeilennr) 

2559 I ELSE editinfo (file, - old zeilennr) 

2560 I FI ; dateizustand holen . 

2561 I 

2562 bildausgabenormieren | bildausgabe normieren : 

2563 I bildbereich := undefinierter bereich; 

2564 I erster neusatz := 9999; 

2565 I letzter neusatz := 0 . 

2566 I 

2567 neuesbildbeiundefinler | neues bild bei undefinierter benutzeraktion : 

2568 I IF bildbereich = undefinierter bereich THEN alles neu FI . 

2569 I END FROC kommando analysieren; 

2570 I 

2571 bildausgabesteuern |PROC bildausgabe steuern : 

2572 I IF markiert 

2573 I THEN IF old mark lineno « 0 
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2574 I THEN abschnitt neu (bildmarke, satznr); 

2575 I konstanten neu berechnen 

2576 I ELIF stelle veraendert 
+ I ( »sh» ) 

2577 I THEN zeile neu 

2578 I FI 

2579 1 ELIF old mark lineno > 0 

2580 I THEN abschnitt neu (old mark lineno» (max (satznr, old lineno))); 

2581 I konstanten neu berechnen 

2582 I FI ; 

2583 I IF satznr <> old lineno 

2584 I THEN neu (akt satznr, nix); 

2585 1 neuen bildaufbau bestimmen 

2586 I ELSE zeilennr := old zeilennr 

2587 I FI ; 

2588 I zeilennr := min (min (zeilennr, satznr), aktuelle bildlaenge); 

2589 I bildanfang := satznr - zeilennr + 1 . 

2590 I 

2591 stelleveraendert | stelle veraendert : stelle <> alte stelle . 

2592 I 

2593 neuenbildaufbaubestimm j neuen bildaufbau bestimmen : 

2594 I zeilennr := old zeilennr + satznr - old lineno; 

2595 I IF 1 <= zeilennr AND zeilennr <= aktuelle bildlaenge 

2596 I THEN im fenster springen 

2597 I ELSE bild neu aufbauen 

2598 I FI . 

2599 I 

2600 imfenster springen |im fenster springen : 

2601 I IF markiert THEN abschnitt neu (old lineno, satznr) FI . 

2602 I 

2603 bildneuaufbauen jbild neu aufbauen : 

2604 I neu (nix, bild); zeilennr := max (1, aktuelle bildlaenge DIV 2) . 

2605 I END PROC bildausgabe steuern; 

2606 I 

2607 wordwrap I PROC word wrap (BOOL CONST b) : 

2608 I IF actual editor = 0 

2609 I THEN std fliesstext := b 

2610 ' I ELSE fliesstext in datei setzen 

2611 I FI . 

2612 I 

2613 fliesstextindateisetze j fliesstext in datei setzen : 

2614 I fliesstext := b; 

2615 I IF fliesstext veraendert THEN editinfo (file, - editinfo (file)) 
+ I FI; 

2616 I neu (ueberschrift, bild) . 

2617 I 

2618 fliesstextveraendert [fliesstext veraendert : 

2619 I fliesstext AND editinfo (file) < 0 OR 

2620 I NOT fliesstext AND editinfo (file) > 0 . 

2621 I END PROC word wrap; 

2622 I 
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2623 wordwrap | BOOL PROC word wrap : 

+ I ( *sh» ) 

2624 I IF actual editor = 0 

2625 I THEN std fllesstext 

2626 I ELSE fliesstext 

2627 1 FI 

2628 I END PROC word wrap; 

2629 I 

2630 margin |INT PROC margin : anfang END PROC margin; 

2631 I 

2632 margin | PROC margin ( INT CONST i ) : 

+ I (•sh«) 

2633 I IF anfang <> i CAND i > 0 AND i < 16001 

2634 I THEN anfang := i; neu (ueberschrift, bild); 

2635 I msurgin segment in ueberschrift eintragen 

2636 I ELSE IF i >= 16001 OR i < 0 

2637 I THEN errorstop ( *'ungueltige Anfangsposition (1 - 16000)") 

2638 I FI 

2639 I FI . 

2640 I 

2641 marginsegmentinuebersc | margin segment in ueberschrift eintragen : 

2642 I replace (ueberschrift text, 2, margin segment) . 

2643 I 

2644 marginsegment {margin segment : 

2645 I IF anfang <= 1 

2646 I THEN " " 

2647 I ELSE TEXT VAR margin text := "M" + text (anfang); 

2648 I (6 - LENGTH margin text) + margin text 

2649 I FI . 

2650 I 

2651 lEND PROC margin; 

2652 I 

2653 rubinmode {BOOL PROC rubin mode : rubin mode (actual editor) END PROC rubi^ 

■*■ I mode ; 

2654 I 

2655 rubinmode |BOOL PROC rubin mode (INT CONST editor nr) : 

+ I (»sh») 

2656 I IF editor nr < 1 OR editor nr > max used editor 

2657 I THEN errorstop ("Editor nicht eroeffnet**) 

2658 I FI ; 

2659 I IF editor nr = actual editor 

2660 I THEN einfuegen 

2661 j ELSE editstack (editor nr) .feldstatus. einfuegen 

2662 I FI 

2663 I END PROC rubin mode; 

2664 I 

2665 edit |PROC edit (INT CONST i, TEXT CONST res, 

2666 I PROC (TEXT CONST) kommando interpreter) : 

2667 I edit (i, i, i, res, PR(X: (TEXT CONST) kommando interpreter) 

2668 I END PROC edit; 
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2670 edit |PROC edit (INT CONST von, bis, start, TEXT CONST res, 

2671 I PROC (TEXT CONST) kommando interpreter) : 

2672 I disable stop; 

2673 I IF von < bis 

2674 I THEN edit (von+1, bis, start, res, PROC (TEXT CONST) kommando 
+ I interpreter); 

2675 I IF max used editor < von THEN LEAVE edit FI; 

2676 I open editor (von) 

2677 I ELSE open editor (start) 

2678 I FI ; 

2679 I absatz ausgleich := 2; 

2680 I bildeditor (res, PROC (TEXT CONST) kommando interpreter); 

2681 I cursor (1, schirmhoehe ) ; 

2682 I IF is error 

2683 I THEN kommando zeiger := 1; kommando :» ""; quit 

2684 j FI ; 

2685 I IF lernmodus CAND actual editor = 0 THEN warnung ausgeben FI . 
+ I (♦sh») 

2686 I 

2687 warnungausgeben | warnung ausgeben : 

2688 I out (clear eop); out ("WARNUNG: Lernmodus nicht 
+ I ausgeschaltet*'l3'**'10'"') . 

2689 I END PROC edit; 

2690 I 

2691 dateizustandholen |PROC dateizustand holen : 

2692 I modify (file); 

2693 I get tabs (file, tabulator); 

2694 I zeilennr und fliesstext und letzter editor aus editinfo decodleren; 

2695 j limit := max line length (file); 

2696 I stelle := col (file); 

2697 I markiert := mark (file); 

2698 I IF markiert 

2699 I THEN markierung holen 

2700 I ELSE keine markierung 

2701 I FI ; 

2702 I satz nr := lineno (file); 

2703 I IF zeilennr > aktuelle bildlaenge 
+ I (wsh*) 

2704 I THEN zeilennr min (satznr, aktuelle bildlaenge); bild neu 

2705 I ELIF zeilennr > satznr 

2706 I THEN zeilennr := min (satznr, aktuelle bildlaenge) 

2707 I FI ; zeilennr := max (zeilennr, 1); 

2708 I bildanfang := satz nr - zeilennr + 1 . 

2709 1 

2710 zeilennrundfliesstextu j zeilennr und fliesstext und letzter editor aus editinfo decodieren : 

2711 I zeilennr := edit info (file); 

2712 I IF zeilennr = 0 

2713 I THEN zeilennr := 1; 

2714 I fliesstext := std fliesstext 

2715 I ELIF zeilennr > 0 

2716 I THEN fliesstext := TRUE 

2717 I ELSE zeilennr := - zeilennr; 

2718 I fliesstext := FALSE 

2719 I FI ; 

2720 I letzer editor auf dieser datei := zeilennr DIV 256; 
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2721 
2722 

2723 markiorungholen 

2724 

2725 

2726 

2727 

2728 

2729 

2730 

2731 

2732 

2733 keinemarkierung 

2734 

2735 

2736 

2737 

2738 



2739 dateizustandretten 

2740 

2741 

2742 

2743 

2744 

2745 

2746 

2747 

2748 

2749 

2750 

2751 

2752 



2753 openeditor 

2754 
2755 
2756 
+ 

2757 

2758 neuebildparameterbesti 

2759 

2760 

2761 

2762 

2763 

2764 

2765 teilbilddesaktuellened 
2766 
2767 
+ 

2768 
2769 
2770 
2771 
2772 



zeilennr := zeilonnr MOD 256 . 



markierung holan : 
bildmarke := mark lineno (file); 
feldmarke := mark col (file); 
IF line no (file) <= bildmarke 
THEN to line (file, bildmarke); 

marke := feldmarke; 

stelle := max (stelle, feldmarke) 
ELSE marke := 1 
FX . 



keine markierung : 

bildmarke := 0; 

feldmarke := 0; 

marke := 0 . 
END FROC date izu stand holen; 



PROC dateizustand retten : 
put tabs (file, tabulator); 
IF fliesstext 

THEN editinfo (file, zeilennr actual editor « 256) 
ELSE editinfo (file, - (zeilennr + actual editor « 256)) 
FI ; 

max line length (file, limit); 
col (file, stelle) ; 
IF markiert 

THEN mark (file, bildmarke, feldmarke) 
ELSE mark (file, 0, 0) 

FI 

END PROC dateizustand retten; 



PROC open editor (FILE CONST new file, BOOL CONST access) : 
disable stop; quit last; 
neue bildparameter bestimmen; 

open editor (actual editor + 1, new file, access, x, y, x len, y 
len). 



neue bildparameter bestimmen : 
INT VAR X, y, x len, y len; 
IF actual editor > 0 
THEN teilbild des aktuellen editors 
ELSE voiles bild 
FI . 



teilbild des aktuellen editors : 
get editcursor (x, y); bildgroesse bestimmen; 
IF fenster zu schmal 
(*sh») 

THEN enable stop; errors top ("Fenster zu klein") 

ELIF fenster zu kurz 

THEN verkuerztes altes bild nehmen 

FI . 
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2773 bildgroessebestimmen |bildgroesse bestiimnen : 

2774 I X len :» rand + feldlaenge - x + 3; 

2775 I y len := bildrand + bildlaenge - y + 1 . 

2776 i 

2777 fensterzuschmal jfenster zu schmal : x > schirmbreite - 17 . 

2776 fensterzukurz jfenster zu kurz : y > schirmhoehe - 1 . 

2779 I 

2780 verkuerztesaltesbildne jverkuerztes altes bild nehmen : 

2781 I X := rand + 1; y := bildrand + 1; 

2782 I IF fenster zu kurz THEN enable stop; errorstop ('*Fenster zu 
+ I klein") FI; 

2783 I X len := feldlaenge + 2; 

2784 I y len := bildlaenge; 

2785 I kurze feldlaenge := 0; 

2786 I kurze bildlaenge := 1 . 

2787 I 

2788 vollesbild | voiles bild : 

2789 I x:=l;y:=l;x len := schirmbreite; y len := schirmhoehe . 

2790 I END PROC open editor; 

2791 I 

2792 openeditor |PROC open editor (INT CONST editor nr, 

2793 I FILE CONST new file, BOOL CONST access, 

2794 j INT CONST x start, y, x len start, y len) : 

2795 I INT VAR X := x start, 

2796 I X len := X len start; 

2797 I IF editor nr > max editor 

2798 I THEN errorstop ("zu viele Editor-Fenster") 

2799 I ELIF editor nr > max used editor + 1 OR editor nr < 1 

2800 I THEN errorstop ("Editor nicht eroeffnet") 

2801 I ELIF fenster ungueltig 

2802 I THEN errorstop ("Fenster ungueltig") 

2803 I ELSE neuen editor stacken 

2804 I FI . 

2805 I 

2806 fensterungueltig jfenster ungueltig : 

2807 I X < 1 COR X > schirmbreite COR y < 1 COR y > schirmhoehe COR 

2808 I X len - 2 <= 15 COR y len - 1 < 1 COR 

2809 j X + X len - 1 > schirmbreite COR y + y len - 1 > schirmhoehe . 

2810 I 

2611 neueneditorstacken | neuen editor stacken : 

2812 j disable stop; 

2813 j IF actual editor > 0 AND ist einschraenkung des alten bildes 

2814 I THEN dateizustand ho len; 

2815 j aktuelles editorbild einschraenken; 

2816 j arbeitspunkt in das restbild positionleren; 

2817 j abgrenzung beruecksichtigen 

2818 j FI ; 

2819 j aktuellen zustand retten; 

2820 I neuen zustand setzen; 

2821 I neues editorbild zeigen; 

2822 j actual editor := editor nr; 

2823 j IF actual editor > max used editor 

2824 j THEN max used editor := actual editor 

2825 I FI . 
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2827 isteinschraenkungdesal |ist einschraenkung des alten bildes : 

2828 I X > rand CAND x + x len = rand + feldlaenge + 3 CAND 

2829 I y > bildrand CAND y + y len » bildrand + bildlaenge + 1 . 

2830 I 

2831 aktuelleseditorbildein |aktuelles editorbild einschraenken : 

2832 I kurze feldlaenge := x - rand - 3; 

2833 I kurze bildlaenge := y - bildrand - 1 . 

2834 I 

2835 arbeitspunktindasrestb jarbeitspunkt in das restbild positionieren : 

2836 1 IF stelle > 3 

2837 j THEN stelle DECR 3; alte stelle := stelle 

2838 I ELSE WHILE zeilennr > 1 AND zeilennr > kurze bildlaenge REP 

2839 I vorgaenger 

2840 I PER; old lineno := satznr 

2841 I FI , 

2842 I 

2843 abgrenzungberuecksicht jabgrenzung beruecksichtigen : 

2844 I IF X - rand > 1 

2845 j THEN balken malen; 

2846 I X INCR 2; 

2847 I X len DECR 2 

2848 I FI . 

2849 I 

2850 balkennalen j balken malen : 

2851 I INT VAR i; 

2852 I FOR i FROM © UPTO y len-1 REP 

2853 I cursor (x» y+i); out (kloetzchen) 
+ I (•sh*) 

2854 I PER . 

2855 I 

2856 kloetzchen | kloetzchen : IF mark size > 0 THEN "»'i5'"»i4«'' ELSE "'•15" "14" " FI . 

2857 I 

2858 aktuellenzustandretten |aktuellen zustand retten : 

2859 I IF actual editor > 0 

2860 I THEN dateizustand retten; 

2861 I editstack (actual editor) . feldstatus := feldstatus; 

2862 I editstack (actual editor) .bildstatus := bildstatus; 

2863 I einrueckstack (actual editor) := alte einrueckposition 

2864 I FI . 

2865 I 

2866 neuenzustandsetzen jneuen zustand setzen : 

2867 I FRANCE VAR f range; 

2868 I feldstatus := FELDSTATUS : 

2869 I (1, 1, x-1, 0, 1, 0, X len-2, 0, FALSE, TRUE, access, ""); 

2870 I bildstatus := BILDSTATUS : 

2871 I (x len-2, x len-2, y, y len-1, y len-1, ueberschrif t , bild, 

2872 I 0, 0, 1, 0, 0, FALSE, FALSE, "", "", "", "", "", frange, new 
+ I file); 

2873 I alte einrueckposition := 1; 

2874 I dateizustand holen; 

2875 I ueberschrift initialisieren . 

2876 I 
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2877 neueseditorbildzoigen |neues editorbild zeigen : 

2878 I ueberschrift zeigen; fenster zeigen 

2879 I END PROC open editor; 

2880 I 

2881 openeditor |PROC open editor (INT CONST i) : 

2882 I IF i < 1 OR i > max used editor 

2883 I THEN errorstop ("Editor nicht eroeffnet**) 

2884 I ELIF actual editor <> i 

2885 I THEN switch editor 

2886 I FI . 

2887 I 

2888 switcheditor j switch editor : 

2889 I aktuellen zustand retten; 

2890 I actual editor := i; 

2891 I neuen zustand setzen; 

2892 I IF kein platz raehr fuer restfenster 

2893 I THEN eingeschachtelte editoren vergessen; 

2894 I bildeinschraenkung aufheben 

2895 I ELSE neu (nix, nix) 

2896 1 FI . 

2897 I 

2898 aktuellenzustandretten | aktuellen zustand retten : 

2899 I IF actual editor > 0 

2900 I THEN editstack (actual editor) .feldstatus :>= feldstatus; 

2901 I editstack (actual editor) .bi Ids tatus := bildstatus; 

2902 I einrueckstack (actual editor) := alte einrueckposition; 

2903 I dateizustand retten 

2904 I FI . 

2905 I 

2906 neuenzustandsetzen | neuen zustand setzen : 

2907 I feldstatus := editstack (i) .feldstatus; 

2908 I bildstatus := editstack (i) .bildstatus; 

2909 I alte einrueckposition :> einrueckstack (1); 

2910 I dateizustand holen . 

2911 I 

2912 keinplatzmehrfuerrestf jkein platz mehr fuer restfenster : 

2913 I kurze feldlaenge < 1 AND kurze bildlaonge < 1 . 

2914 I 

2915 eingeschachtelteeditor [eingeschachtelte editoren vergessen : 

2916 I IF actual editor < max used editor 

2917 I THEN open editor (actual editor + 1) ; 

2918 I quit 

2919 I FI ; 

2920 I open editor (i) . 

2921 I 

2922 bildeinschraenkungaufh | bildeinschraenkung aufheben : 

2923 I laenge feldlaenge; 

2924 I kurze feldlaenge := feldlaenge; 

2925 I kurze bildlaenge := bildlaonge; 

2926 I neu (ueberschrift, bild) . 

2927 I END PROC open editor; 

2928 I 
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2929 


editfile 


. . IFILE PROC editfile : 




2930 




j IF actual editor 


« 0 OR editget modus 


2931 




1 THEN errorstop ("Editor nicht eroeffnet") 


2932 




1 FI ; file 




2933 




|END PROC editfile; 




2934 








2935 


getwindow 


..|PROC get window (INT VAR x, y, x size, y size) : 


2936 




I X := rand + 1; 




2937 




1 y := bildrand; 




2938 




1 X size := feldlaenge 2; 


2939 




1 y size := bildlaenge + 1 


2940 




lENDPROC get window; 




2941 








2942 








+ 

2943 




— 




2944 


feldlaenge 


1 feldlaenge 


bi Ids tatus. feldlaenge . 


2945 


kurzefeldlaenge 


jkurze feldlaenge 


bildstatus.kurze feldlaenge . 


2946 


bildrand 


1 bildrand : 


bi Ids tatus. bildrand . 


2947 


bildlaenge 


1 bildlaenge : 


bildstatus. bildlaenge . 


2948 


kurzebi Idlaenge 


|kurze bildlaenge : 


bildstatus.kurze bildlaenge . 


2949 


ueborschriftbereich 


lueberschriftbereich : 


bildstatus . ueberschrif tbereich 


2950 


bildbereich 


1 bildbereich 


bildstatus. bildbereich . 


2951 


ersterneusatz 


lerster neusatz 


bildstatus. erster neusatz . 


2952 


letzterneusatz 


jletzter neusatz : 


bildstatus. letzter neusatz . 


2953 


oldzeilennr 


jold zeilennr : 


bildstatus. old zeilennr . 


2954 


oldllneno 


1 

1 old lineno i 


bildstatus . old lineno . 


2955 


oldmarkllneno 


|old mark lineno 


bildstatus. old mark lineno . 


2956 


zeileneinfuegen 


1 zeileneinfuegen 


bildstatus. zeileneinfuegen . 


2957 


oldllneupdate 


|old line update 


bildstatus. old line update . 


2958 


satznrpre 


Isatznr pre 


bildstatus. satznr pre . 


2959 


ueberschriftpre 


1 ueber schr if t pre 


bildstatus. ueberschri ft pre . 


2960 


ueberschrifttext 


lueberschrift text : 


bildstatus. ueberschrif t text . 


2961 


ueber schri f tpo s t 


jueberschrift post : 


bi Ids tatus. ueberschrif t post . 


2962 


oldsatz 


jold satz : 


bildstatus. old satz . 


2963 


oldrange 


|old range 


bildstatus. old range . 


2964 


file 


(file : 


bildstatus. file . 


2965 








2966 




|END PACKET editor paket; 
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1 editorf unctions | PACKET editor functions DEFINiS (• FUNCTIONS 
+ I 052 •) 

2 I («4H»«»«««*»««»«) (• 17.07.85 
+ I -bk- •) 

3 I (• 10.09.85 
+ I -ws- •) 

4 I edit, (• 25.04.86 
+ I -sh- •) 

5 I show, (• 27.05.86 
+ I -wk- ♦) 

6 I U, 

7 I D, 

8 I T, 

9 I up, 

10 I down, 

11 I downety, 

12 I uppety, 

13 I to line, 

14 I PUT, 

15 I GET, 

16 I P, 

17 I G, 

18 I limit, 

19 I len, 

20 I eof, 

21 I C, 

22 I change to, 

23 I CA, 

24 I change all, 

25 I lines, 

26 I line no, 

27 1 col, 

28 I mark, 

29 I at, 

30 I word , 

31 I std kommando interpreter, 

32 j note , 

33 I note line, 

34 I note edit, 

35 I anything noted, 

36 I note file: 

37 I 

38 I 

39 I LET marker 

40 I ersatzmarker = 

41 I schritt = 50, 

42 I file size = 4072, 

43 I write acc = TRUE, 

44 I read acc « FALSE; 

45 I 

46 I LET bold = 2, 

47 I integer = 3, 
46 I string = 4, 

49 I end of file = 7; 

50 I 

51 I LEI std res = "eqvwl9dpgn"9"" ; 

52 I 

53 [FILE VAR edfile; 

54 I BOOL VAR from scratchfile :: FALSE; 

55 I TEXT VAR kommando text , tabulator, zeile; 

56 I 

57 I 
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58 


stdkotmandointerpreter . . . 


|xvuc std Konnando interpreter vii!>Ai uunoi L&sLe; . 


59 




1 enable stop ; 


60 




1 edfile :» editfile; 


61 




1 set busy indicator; 


62 




1 SELECT pos (std res, taste) OF 


63 




1 PACC* 1 ( »Am\ • A/4 If 


64 




1 UAoJit c V*<],*y . qUlX 


65 




1 CAS£ 3 v*v*y • q.uit last 


66 




1 CASE 4 (*w*) I open editor (next editor) 


67 




1 CAS£ D v*i*^ • toiine 11/, coi vi; 


68 




1 LAoJii D v*7*/ bOiine vxinos^, cox vxon'rx; 


69 




1 CASE 7 («d») : d case 


70 




1 CASE 8 (•?•) : p case 


71 




1 CASE 9 (•g*) I g case 


72 




\ CASE 10V *n»; I note edit 


73 




1 uAoii iiv*baD*;. cnange mids 


74 




1 v/ituinif iDi!< ecnxes kouHwuicio ujinxjsxoron 


f 0 




1 irun QTiT PPT 


76 






77 


dC&S6 


1 d case 


78 




1 IF mark 


79 




1 THEN PUT \ mark viALoiijj, rrom scrabcnriie .= invh 


80 




1 EI^E textzeile auf taste legen 


81 




1 FI . 


82 






83 


pease 


|p case : 


84 




1 IF mark 


•f 




1 (•sh*) 


85 




1 THEN IF write permission 


OD 




THICN PUT nushf ****27''"12"") • from scratchfile 


87 




1 MtOCi OUX V ' ^ 


88 






89 




1 ELSE textzeile auf taste legen 


90 




1 PT 
1 X 1 . 


91 






92 


gcase 


|g case : 


93 




1 IF write permission 


+ 




1 (•sh*) 


94 




1 THEN IF from scratchfile 


95 




1 THEN GET 


96 




1 ELSE IF is editget 


^ f 




1 TUPM miaVi f 1 AT*naA/iiiAn7 aii^ f^afiA (^tT^\\' 


98 




1 FI 


99 




1 FI 


100 




1 fiLoJit OUX \ f ) 


101 




1 FI . 


102 






103 


tex t ze 1 le&uf t&s to lege n 


1 textzeile auf taste legen i 


104 




1 read record (edfile, zeile); 


105 




1 zeile i« subtext (zeile, col)i 


106 




1 lernsequenz auf taste legen (**g*', zeile); 


107 




1 from scratchfile FALSE; zeile neu . 


108 






109 


next editor 


jnext editor : 


110 




1 (aktueller editor MOD groesster editor) + 1 . 


111 
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112 changetabs | change tabs : 

113 I get tabs (edflle, tabulator) ; 

114 I IF pes (tabulator, marker) <> 6 

115 I THEN change all (tabulator, marker, ersatzmarker) 

116 I ELSE change all (tabulator, ersatzmarker, marker) 

117 I FI ; 

118 I put tabs (edfile, tabuUtor) ; 

119 I ueberschrift neu . 
126 I 

121 echteskoimnandoanalysie jechtes kommando analysleren : 

122 I konmandotext :« kommando auf taste (taste); 

123 I IF komroandotext = 

124 I THEN nichts neu; LEAVE std konmando interpreter 

125 I FI ; 

126 j scan (kommandotext) ; 

127 I TEXT VAR si; INT VAR tl; next symbol (si, tl); 

128 I TEXT VAR s2; INT VAR t2; next symbol (s2, t2); 

129 I IF tl - integer AND t2 = end of file TOQI toline (int (si)) 

130 I ELIF tl = string AND t2 « end of file THEN down (si) 

131 I ELIF perhaps simple up or down THEN 

132 I ELIF perhaps simple changeto THEM 

133 I ELSE do (kommandotext) 

134 I FI . 

135 I 

136 perhapssimpleupordown | perhaps simple up or down : 

137 I IF tl = bold 

138 I THEN TEXT VAR s3; INT VAR t3; next symbol (s3, t3) ; 

139 I IF t3 <> end of file THEN FALSE 

140 I ELIF si - "U"* THEN perhaps simple up 

141 I ELIF si = **D** THEN perhaps simple down 

142 I ELSE FALSE 

143 I FI 

144 I ELSE FALSE 

145 1 FI . 

146 I 

147 perhapssimpleup j perhaps simple up : 

148 I IF t2 - string THEN up (s2); TRUE 

149 I ELIF t2 . integer THEN up (int (s2)); TRUE 

150 I ELSE FALSE 

151 I FI . 

152 I 

153 perhapssimpledown j perhaps simple down : 

154 I IF t2 = string THEN down (s2); TRUE 

155 I ELIF t2 = integer THEN down (int (s2)); TRUE 

156 I ELSE FALSE 

157 I FI . 

158 I 

159 perhapssimplechangeto (perhaps simple changeto : 

160 I IF tl = string AND s2 » "C" AND t3 is string AND U is eof 

161 I THEN si C s3; TRUE 

162 I ELSE FALSE 

163 I FI . 

164 I 

165 t3isstring |t3 is string : 

166 I next symbol (s3, t3); 

167 I t3 = string . 
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168 I 

169 t4iseof jt4 is eof ; 

170 I TEXT VAR s4; INT VAR t4; 

171 I next symbol {s4, t4); 

172 I t4 = end of file . 

173 I END PROC std konmiando interpreter; 

174 I 

175 I 

176 edit |PROC edit (TILE VAR f) : 

177 I enable stop; 

178 I ir aktueller editor > 0 
+ I (*wk*) 

179 I THEN ueberschrift neu 

180 I n ; 

181 I open editor (f, write acc); 

182 I edit (groesster editor, std res, PROC(TEXT CONST) std kommando 
+ I interpreter) 

183 I END PROC edit; 

184 I 

185 I 

186 edit IPROC edit (FILE VAR f, INT CONST x, y. x size, y size) : 

187 I enable stop; 

188 I open editor (groesster editor ♦I, f, write acc, x, y, x size, y 
+ I size); 

189 I edit (groesster editor, std res, PROC(TEXT CONST) std kommando 
+ I interpreter) 

190 I END PROC edit; 

191 I 

192 I 

193 edit |PROC edit (TILE VAR f , TEXT CONST res, PROC (TEXT CONST) kdo 

+ I interpreter) : 

194 I enable stop; 

195 I open editor (f, write acc); 

196 I edit (groesster editor, res, PROC(TEXT CONST) kdo interpreter) 

197 I END PROC edit; 

198 I 

199 I 

200 edit IPROC edit : 

201 I IF aktueller editor > 0 

202 I THEN dateinarae einlesen; 

203 I edit (dateiname) 

204 I ELSE edit (last param) 

205 I FI . 

206 I 

207 dateinameeinlesen j dateiname einlesen : 

208 I INT VAR X, y; get editcursor (x, y); 

209 I IF x < x size - 17 
+ I ( •sh* ) 

210 I THEN cursor (x, y); 

211 I out (•'"15"Dateiname:"14'*"); 

212 I (x size-14-x) TIMESOUT " "; 

213 I (X size-14-x) TIMESOUT ""a"*'; 
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214 I TEXT VAR dateiname := std; 

215 I editget (datelnane); 

216 I trailing blanks entfernon; 

217 I quotes entfernen 

218 I ELSE errorstop ("Fenster zu klein") 

219 I FI . 

220 I 

221 trailingblanksentferne | trailing blanks entfernen: 

222 I INT VAR i := LENGTH dateiname; 

223 I WHILE (dateiname SUB i) - ** REP i DECR 1 PER; 

224 I dateiname := subtext (dateiname, 1, i) . 

225 I 

226 quotesentfernen | quotes entfernen : 

227 I IF (dateiname SUB 1) = AND (dateiname SUB LENGTH dateiname) 
+ I 

228 I THEN dateiname := subtext (dateiname, 2, LENGTH dateiname - 1) 

229 I FI . 

230 I END PROC edit; 

231 I 

232 I 

233 edit |PROC edit (TEXT (X)NST filename) : 

234 I IF filename <> 

235 I THEN edit n«uned file 

236 I ELSE errorstop ("Name ungueltig**) 

237 I FI . 

238 I 

239 editnamedfile jedit named file : 

240 I last param (filename); 

241 I IF exists (filename) COR yes ("""" + filename + neu 
+ I einrichten") 

242 I THEN IF aktueller editor > 0 THEN ueberschrift neu FI; 
+ I (*»sh«) 

243 I FILE VAR f := sequential file (modify, filename); 

244 I headline (f, filename); edit (f); last param (filename) 

245 I ELSE errorstop 

246 I FI . 

247 I END PROC edit; 

248 I 

249 I 

250 edit |PROC edit (TEXT CONST filename, INT CONST x. y, x size, y size) : 

251 I last param (filename); 

252 I IF exists (filename) COR yes ("*•"" •»• filename ■^ neu 
+ I einrichten*') 

253 I THEN FILE VAR f := sequential file (modify, filename); 

254 I headline (f, filename); edit (f, x, y, x size, y size); 

255 I last param (filename) 

256 I ELSE errorstop ("**) 

257 I FI 

258 I END PROC edit; 

259 I 
260 
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261 edit |PROC edit (INT CONST i) : 

262 I edit (i» std res, PROC (TEXT CONST) std konmando interpreter) 

263 lEND PROC edit; 

264 I 

265 I 

266 show I PROC show (FILE VAR f) : 

267 I enable stop; 

268 I open editor (f» read acc); 

269 I edit(groesster editor, std res. PROC(TKXT CONST) std kommando 
+ I interpreter); 

27© I ENS PROC show; 

271 I 

272 I 

273 show I PROC show (TEXT CONST filename) : 

+ I (♦sh*) 

274 I last param (filename); 

275 I IF exists (filename) 

276 I THEN FILE VAR f ;= sequential file (modify, filename); 

277 I show (f); last param (filename) 

278 I ELSE errorstop ("""" ■»■ filenajne + gibt es nicht") 

279 I FI 

280 I END PROC show; 

281 I 

282 I 

283 show I PROC show : 

284 I show (last param) 

285 I END PROC show; 

286 I 

287 I 

288 IDATASPACE VAR local space; 

289 I INT VAR zeilenoffset; 

290 I TEXT VAR kopierzeile; 

291 I 

292 I 

293 PUT |0P PUT (TEXT CONST filename) : 

294 I nichts neu; 

295 I IF mark 

296 I THEN raarkierten bereich in datel schreiben 

297 I PI • 

298 I 

299 markiertenberoichindat jmarkierten bereich in datei schreiben : 

300 I disable stop; 

301 I zieldatei vorbereiten; 

302 I quelldatei oeffnen; 

303 I IF noch genuegend platz in der zieldatei 
+ I (•sh*) 

304 I THEN zeilenweise kopieren 

305 I ELSE errorstop ("FILE-Ueberlauf") 

306 I ri ; 

307 I quelldatei schliessen; 

308 I zieldatei schliessen; 

309 I set busy indicator . 

310 I 
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311 zieldateivorbereiten 

312 

313 

314 

315 

316 

317 

318 

319 

4- 

320 
321 
322 
323 

324 quelldateioeffnen 
325 
326 
327 
328 
+ 

329 
330 

331 nochgenuegendplatzinde 

332 

333 

334 zeilenweisekopieren 

335 

336 

337 

338 

339 

340 

341 

342 

343 

344 quelldateischliessen 

345 

346 

347 

348 

349 

350 zloldataischliessen 

351 

352 

353 

354 

355 

356 

357 

358 

359 

360 

361 



zieldatei vorbereiten : 
FRANCE VAR ganze zieldatei; 

IF exists (filenanie) THEN forget (filename); ueberschrift neu FI; 
FILE VAR destination; 
IF filenanie = 

THEN forget (local space); local space :> nilspace; 

destination sequential file (output, local space) 
ELSE destination :> sequential file (modify, filename) ; 

INT (X)NST groesse der zieldatei lines (destination); 
(♦sh») 

set marked range (destination, ganze zieldatei) ; 
output (destination) 

FI . 



Iquelldatei oeffnen : 

I zeilenoffset :« mark line no (edfile) - 1; 
INT CX)NST old line :« line no, old col :« col; 
FRANCE VAR ganze datei; 

set range (edfile, mark lineno (edfile), mark col (edfile), ganze 

datei); 
input (edfile) . 



noch genuegend platz in der zieldatei : 
lines * groesse der zieldatei < file size . 



zeilenweise kopieren : 
enable stop; 
satznr neu; 
INT VAR zeile; 

FOR zeile FROM 1 UPTO lines (edfile) REP 
getline (edfile, kopierzeile) ; 
putline (destination, kopierzeile); 
satznr zeigen 

PER . 



Iquelldatei schliessen : 

I modify (edfile); 

I set range (edfile, ganze datei); 

I to line (old line); 

I col (old col) . 



I zieldatei schliessen : 
IF filename <> **" 

THEN INT COHST last line written :« line no (destination) ; 
modify (destination) ; 

to line (destination, last line written) ; 

col (destination, len (destination) 1) ; 

bild neu (destination) ; 
I set range (destination, ganze zieldatei) 

FI . 
END OP PUT; 
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362 P |0P P (TEXT CONST filename) : 

363 I PUT filename 

364 I END OP P ; 

365 I 

366 I 

367 GET I OP GET (TEXT CONST filename) : 

+ I (*sh») 

368 I IF NOT write permission 

369 I THEN errorstop C'Schreibversuch auf * show* -Date i**) 

370 I n ; 

371 1 quelldatei oeffnen; 

372 I IF nicht raehr genuegend platz im editflle 

373 I THEN quelldatei schliessen; errorstop ( "FILE-Ueberlauf * ) 

374 I FI ; 

375 I disable stop; 

376 I zieldatei oeffnen; 

377 1 zeilenweise kopieren ; 

378 I zieldatei schliessen; 

379 I quelldatei schliessen; 

380 I set busy indicator . 

381 I 

382 quelldateioeffnen j quelldatei oeffnen : 

383 I FILE VAR source; 

364 I FRANGE VAR ganze quelldatei; 

385 I IF filename = 

386 I THEN source := sequential file (input, local space) 

387 I ELSE IF NOT exists (filename) 

388 I THEN errorstop (""'**' + filename + gibt es nicht") 

389 I FI ; 

390 I source :» sequential file (modify, filename); 

391 I INT CONST old line := line no (source), 

392 I old col := col (source); 

393 I set marked range (source, ganze quelldatei); 

394 I input (source) 

395 I FI . 

396 I 

397 nichtmehrgenuegendplat j nicht mehr genuegend platz im editfile : 

398 I lines (source) + lines >= file size . 

399 I 

400 zeilenweisekopieren j zeilenweise kopieren : 

401 I enable stop; 

402 I satznr neu; 

403 I INT VAR zeile; 

404 I FOR zeile FROM 1 UPTO lines (source) REP 

405 I getline (source, kopierzeile) ; 

406 I putline (edfile, kopierzeile); 

407 I satznr zeigen 

408 I PER . 

409 I 

410 zieldateioeffnen j zieldatei oeffnen : 

411 I zeilenoffset :« line no - 1; 

412 I leere datei in editfile einschachteln; 

413 I output (edfile) . 

414 I 
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415 leeredatoiineditfileei |leere datei in editfile einschachteln : 

416 I INT CONST range start col := col; 

417 I FRANCE VAR ganze datei; 

418 I set range (edfile, line no, col, ganze datei); 

419 I IF lines = 1 THEN delete record (edfile) FI . 

420 I 

421 quelldateischliessen jquelldatei schliessen : 

422 I IF filename <> 

423 I THEN modify (source); 

424 I set range (source, ganze quelldatei); 

425 I to line (source, old line); 

426 I col (source, old col) 

427 I FI . 

428 I 

429 zieldateischliessen jzieldatei schliessen : 

430 I modify (edfile); 

431 I to line (lines) ; 

432 I col (range start col); 

433 I set range (edfile, ganze datei); 

434 i abschnitt neu (zeilenoffset + 1, lines) . 

435 I END OP GET; 

436 I 

437 I 

438 G |0P G (TEXT CONST filename) : 

439 I (lET filename 

440 I END OP G; 

441 I 

442 I 

443 len I INT PROC len : 

444 I len (edfile) 

445 |END PROC len; 

446 I 

447 I 

448 col I PROC col (INT CONST stelle) : 

449 I nichts neu; col (edfile, stelle) 

450 I END PROC col; 

451 I 

452 I 

453 col I INT PROC col : 

454 1 col (edfile) 

455 I END PROC col; 

456 I 

457 I 

458 limit I PROC limit (INT CONST limit) : 

459 I nichts neu; max line length (edfile, limit) 

460 I END PROC limit; 

461 I 

462 I 
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463 limit I INT PROC limit : 

464 I max line length (edfile) 

465 I END PROC limit; 

466 I 

467 I 

468 lines I INT PROC lines : 

469 I lines (edfile) 

470 I END PROC lines; 

471 I 

472 I 

473 lineno | INT PROC line no : 

474 I line no (edfile) 

475 I END PROC line no; 

476 I 

477 I 

478 toline |PROC to line (INT CONST satz nr) : 

479 I satznr neu; 

480 I edfile := editfile; 

481 I IF satz nr > lines 

482 I THEN toline (edfile, lines); col (len + 1) 

483 I ELSE to line (edfile, satz nr) 

484 I FI 

485 I END PROC to line; 

486 I 

487 I 

488 T |0P T (INT CONST satz nr) : 

489 I to line (satz nr) 

490 I END OP T; 

491 I 

492 I 

493 down |PROC down (INT CONST anz) : 

494 I nichts neu; down (edfile, anz) 

495 I END PROC down; 

496 I 

497 I 

498 D |0P D (INT CONST anz) : 

499 I down (anz) 

500 I END OP D; 

501 I 

502 I 

503 up I PROC up (INT CONST anz) ; 

504 I nichts neu; up (edfile, anz) 

505 I END PROC up; 

506 I 

507 I 
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508 U |0P U (INT CONST anz) : 

509 1 up (anz) 

510 |END OP U; 

511 I 

512 I 

513 down I PROG down (TEXT CONST muster) : 

514 I nichts neu; 

515 I REP 

516 I down (muster, schritt - line no MOD schritt); 

517 I IF pattern found 

518 1 THEN LEAVE down 

519 I ELSE satznr zeigen 

520 I FI 

521 I UNTIL eof PER 

522 I END PROC down; 

523 I 

524 I 

525 D |0P D (TEXT CONST muster) : 

526 I down (muster) 

527 I END OP D; 

528 1 

529 I 

53© down I PROC down (TEXT CONST muster. INT CONST anz) : 

531 I nichts neu; down (edfile, muster, anz) 

532 I END PROC down; 

533 1 

534 1 

535 up I PROC up (TEXT CONST muster) : 

536 I nichts neu; 

537 I REP 

538 I up (muster, (line no - 1) MOD schritt + 1); 

539 I IF pattern found 

540 I THEN LEAVE up 

541 I ELSE satznr zeigen 

542 I FI 

543 I UNTIL line no = 1 PER 

544 I END PROC up; 

545 I 

546 I 

547 U |0P U (TEXT CONST muster) : 

548 I up (muster) 

549 |END OP U; 

550 I 

551 I 

552 up I PROC up (TEXT CONST muster, INT CONST anz) : 

553 I nichts neu; up (edfile, muster, anz) 

554 I END PROC up; 

555 I 

556 I 
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557 dovmety |PROC downety (TEXT CX)NST muster) : 

558 I nichts neu; 

559 I IF NOT at (muster) 

560 I THEN down (muster) 

561 I FI 

562 I END PROC downety; 

563 I 

564 I 

565 downety |PROC downety (TEXT CONST muster, INT CONST anz) : 

566 I nichts neu; downety (edfile, muster, anz) 

567 I END PROC downety; 

568 I 

569 I 

570 uppety |PROC uppety (TEXT CONST muster) : 

571 I nichts neu; 

572 I IF NOT at (muster) 

573 I THEN up (muster) 

574 1 FI 

575 I END PROC uppety; 

576 I 

577 j 

578 uppety |PROC uppety (TEXT CONST muster, INT CONST anz) : 

579 I nichts neu; uppety (edfile, muster, anz) 

580 I END PROC uppety; 

581 I 

582 I 

583 C |0P C (TEXT CONST old, new) : 

584 I change to (old, new) 

585 |END OP C; 

586 I 

587 C |0P C (TEXT CONST replacement) : 

588 I IF NOT write permission 
+ I (•sh*) 

589 1 THEN errorstop ( "Schreibversuch auf 'show*-Datei") 

590 I FI ; 

591 I IF at (edfile, raatch(0)) 

592 I THEN zeile neu; change (edfile, matchpos(e), roatchend(0), 
-t- I replacement) 

593 I FI 

594 I END OP C; 

595 I 

596 changeto |PROC change to (TEXT CONST old, new) : 

597 I IF NOT write permission 
+ I (•sh*) 

598 I THEN errorstop ( "Schreibversuch auf *show*-Datei") 

599 I FI ; 

600 I nichts neu; 

601 I REP 

602 I downety (old, schritt - line no MOD schritt); 

603 I IF pattern found 
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604 I THEN change (edfile, rnatchpos(0), niatchend(0) » new); 

605 I col (col + LENGTH new); zeile neu; 

606 I LEAVE change to 

607 I ELSE satznr zeigen 

608 I FI 

609 I UNTIL eof PER 

610 lEND PROC change to; 

611 I 

612 I 

613 CA |0P CA (TEXT CONST old, new) : 

614 I change all (old, new) 

615 |END OP CA; 

616 I 

617 I 

618 changeall |PROC change all (TEXT CONST old, new) : 

619 I WHILE NOT eof REP old C new PER 

620 I END PROC change all; 

621 I 

622 I 

623 eof I BOOL PROC eof : 

624 I eof (edfile) 

625 I END PROC eof; 

626 I 

627 I 

628 mark I BOOL PROC mark : 

629 I mark (edfile) 

630 I END PROC mark; 

631 I 

632 I 

633 mark I PROC mark (BOOL CONST mark on) : 

634 I nichts neu; 

635 I IP mark on 

636 I THEN mark (edfile, line no, col) 

637 I ELSE mark (edfile, 0, 0) 

638 I FI 

639 I END PROC mark; 

640 I 

641 I 

642 at I BOOL PROC at (TEXT CONST pattern) : 

643 I at (edfile, pattern) 

644 |END PROC at; 

645 1 

646 word |TEXT PROC word : 

647 I word (edfile) 

648 I END PROC word; 

649 I 

650 1 
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651 word I TEXT PROC word (TEXT CONST sep) : 

652 I word (edfile, sep) 

653 lEND PROC word; 

654 I 

655 I 

656 word I TEXT PROC word (INT CONST len) : 

657 I word (edfile, len) 

658 I END PROC word; 

659 I 

660 I 

661 I LET no access = 0, 

662 I edit access = 1, 

663 I output access = 2; 

664 I 

665 I INT VAR last note file mode; 

666 I PILE VAR notebook; 

667 IINITTLAG VAR this packet := FALSE; 

668 IDATASPACE VAR note ds; 

669 I 

670 1 

671 note I PROC note (TEXT CONST text) : 

672 j access note file (output access); 

673 I write (notebook, text) 

674 lEND PROC note; 

675 I 

676 I 

677 note I PROC note (INT CONST number) : 

678 I access note file (output access); 

679 I put (notebook, number) 

680 I END PROC note; 

681 1 

682 I 

683 noteline |PROC note line : 

684 I access note file (output access); 

685 I line (notebook) 

686 I END PEiOC note line; 

687 I 

688 I 

689 anythingnoted |BOOL PROC anything noted : 

690 I access note file (no access); 

691 I last note file mode = output cwjcess 

692 I END PROC anything noted; 

693 1 

694 I 

695 notefile |FILE PROC note file : 

696 I access note file (output access); 

697 I notebook 

698 lEND PROC note file; 

699 I 

700 I 
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701 noteedit |PROC note edit (FILE VAR context) : 

+ I (•sh») 

702 I access note file (edit access); 

703 j make notebook erasable; 

704 I IF aktueller editor = 0 

705 I THEN open editor (1, context, write acc, 1, 1, x size - 1, y 
+ I size) 

706 I FI ; 

707 I get window size; 

708 I IF window large enough 

709 I THEN include note editor; 

710 j edit (aktueller editor-1, aktueller editor, aktueller 
+ I editor-1, 

711 I std res, PRCX3 (TEXT CX)NST) std kommando interpreter) 

712 I FI . 

713 I 

714 getwindowsize jget window size : 

715 I INT VAR x, y, windows x size, windows y size; 

716 I get window (x, y, windows x size, windows y size) . 

717 I 

718 window largeenough | window large enough : 

719 I windows y size > 4 . 

720 I 

721 includenoteeditor j include note editor : 

722 I open editor (aktueller editor + 1, notebook, write acc, 

723 I X, y + (windows y size + 1) DIV 2, 

724 I windows x size, windows y size DIV 2) . 

725 I 

726 makenotebookerasable (make notebook erasable : 

727 I last note file mode := edit access . 

728 I END PROC note edit; 

729 I 

730 I 

731 noteedit |PROC note edit : 

732 I access note file (edit access); 

733 I make notebook erasable; 

734 I edit (notebook) . 

735 1 

736 makenotebookerasable jmake notebook erasable : 

737 I last note file mode :« edit access . 

738 lEND PROC note edit; 

739 I 

740 I 

741 accessnoteflle |PROC access note file (INT (X)NST new mode) ; 

742 I disable stop; 

743 I initialize note ds if necessary; 

744 I IF last note file mode < new mode 

745 I THEN forget (note ds); 

746 j note ds := nilspace; 

747 I notebook :« sequential file (output, note ds); 

748 I headline (notebook, "notebook"); 

749 I last note file mode :« new mode 

750 I FI . 
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751 

752 initializenotedsifnece 

753 

754 

755 

756 

757 

758 

759 



[initialize note ds if necessary : 

I IF NOT initialized (this packet) 

I THEN note ds := nilspace; 

I last note file mode :> no access 

I ri . 

END FROC eu:cess note file; 
END PACKET editor functions; 
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1 |(, VERSION 2 06.03.86 •) 

2 stdtransput j PACKET std transput DEFINES 

3 I 

4 I sysout , 

5 I sysin , 

6 I put , 

7 I putline , 

8 I line , 

9 I pa«e , 

10 I write , 

11 I got , 

12 I getline , 

13 I get secret line : 

14 I 

15 I 

16 ILET cr = *'*'13***' , 

17 I cr If = nrr^^n^^^nn ^ 

18 I home clear = *'"i'»"4'*" , 

19 I esc = ''*'27**** » 

20 I rubout = ""j^g**" » 

21 I bell = •**'7''" , 

22 I back blank back = ***'8*' "8"" , 

23 I del line cr If = "♦•s^^is'^'i©-" ; 

24 I 

25 I TEXT VAR number word , exit char ; 

26 I 

27 I BOOL VAR console output := TRUE, console input :« TRUE ; 

28 I 

29 I FILE VAR outfile, infile ; 

30 I TEXT VAR outfile name infile name :«****; 

31 I 

32 I 

33 sysout IPROC sysout (TEXT CONST file name) : 

34 I 

35 I outfile name := file name ; 

36 I IF file name = 

37 I THEN console output := TRUE 

38 I ELSE outfile := sequential file (output, file name) ; 

39 I console output := FALSE 

40 I FI 

41 I 

42 lENDPROC sysout ; 

43 I 

44 sysout I TEXT PROC sysout : 

45 j outfile name 

46 lENDPROC sysout ; 

47 I 

48 sysin I PROC sysin (TEXT CONST file name) : 

49 I 

50 I infile name := file name ; 

51 I IF file name = **** 

52 I THEN console input := TRUE 

53 I ELSE infile := sequential file (input, file name) ; 

54 I console input := FALSE 

55 I FI 

56 I 
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57 lENDPROC sysin ; 

58 I 

59 sysin |TEXT PROC sysin : 

60 I infile name 

61 lENDPROC sysin ; 

62 I 

63 I 

64 put I PROC put (TEXT CONST word) : 

65 I 

66 I IF console output 

67 I THEN out (word) ; out (** **) 

68 I ELSE put (outfile, word) 

69 1 FI 

70 I 

71 lENDPROC put ; 

72 I 

73 put I PROC put (INT CONST number) : 

74 I 

75 I put (text (number)) 

76 I 

77 lENDPROC put ; 

78 I 

79 put I PROC put (REAL CONST number) : 

80 1 

81 I put (text (number)) 

82 I 

83 lENDPROC put ; 

84 1 

85 putline |PROC putline (TEXT CONST textline) : 

86 I 

87 I IF console output 

88 I THEN out (textline) ; out (cr If) 

89 I ELSE putline (outfile, textline) 

90 I FI 

91 I 

92 lENDPROC putline ; 

93 I 

94 line |PROC line : 

95 I 

96 I IF console output 

97 I THIN out (cr If) 

98 I ELSE line (outfile) 

99 I FI 

100 I 

101 lENDPROC line ; 

102 I 
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103 line |PROC line (INT CONST times) : 

104 I 

105 I INT VAR i ; 

106 I FOR i FROM 1 UPTO times REP 

107 I line 

108 I PER 

109 I 

110 lENDPROC line ; 

111 I 

112 page IPROC page : 

113 I 

114 I IF console output 

115 I THEN out (home clear) 

116 I FI 

117 I 

118 lENDPROC page ; 

119 1 

120 write |PROC write (TEXT CONST word) : 

121 I 

122 I IF console output 

123 I THEN out (word) 

124 I ELSE write (outfile, word) 

125 1 FI 

126 I 

127 lENDPROC write ; 

128 I 

129 I 

130 get IPROC get (TEXT VAR word) : 

131 I 

132 I IF console input 

133 I THEN get from console 

134 I ELSE get (infile, word) 

135 I FI . 

136 I 

137 getfromconsole jget from console : 

138 I REP 

139 1 word 

140 1 editget (word, " **, exit char) ; 

141 I echoe exit char 

142 I UNTIL word <> **" AND word <> " PER ; 

143 I delete leading blanks . 

144 I 

145 delete lead! ngblanks | delete leading blanks : 

146 I WHILE (word SUB 1) = " ** REP 

147 I word := subtext (word, 2) 

148 I PER . 

149 I 

150 lENDPROC get ; 

151 I 

152 get jPROC get (TEXT VAR word, TEXT CONST separator) : 

153 I 

154 I IF console input 
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155 I THEN get from console 

156 I ELSE get (infile, word, separator) 

157 1 FI . 

158 I 

159 getfromconsole |get from console : 

160 I word := ; 

161 I editget (word, separator, exit char) ; 

162 I echoe exit char . 

163 I 

164 lENDPROC get ; 

165 I 

166 echoeexitchar | PROC echoe exit char : 

167 I 

168 I IF exit char = ""13"" 

169 I THEN out ( '♦"13"''10"*') 

170 I ELSE out (exit char) 

171 I FI 

172 I 

173 lENDPIWC echoe exit char ; 

174 I 

175 get I PROC get (INT VAR number) : 

176 I 

177 I get (number word) ; 

178 I number := int (number word) 

179 I 

180 lENLPROC get ; 

181 I 

182 get I PROC get (REAL VAR number) : 

183 I 

184 I get (number word) ; 

185 I number := real (number word) 

186 I 

187 lENDPROC get ; 

188 I 

189 get I PROC get (TEXT VAR word, INT CONST length) : 

190 I 

191 I IF console input 

192 I THEN get from console 

193 I ELSE get (infile, word, length) 

194 I FI . 

195 I 

196 getfromconsole jget from console : 

197 I word :=*"*; 

198 I editget (word, length, exit char) ; 

199 I echoe exit char . 

200 I 

201 lENDPROC get ; 

202 i 
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203 getline |PROC getline (TEXT VAR textline) : 

204 I 

205 I IF console input 

206 I THEN get from console 

207 I ELSE getline (infile» textline) 

208 I FI . 

209 1 

210 getfromconsole |get from console : 

211 I textline 

212 I editget (textline, exit char) ; 

213 I echoe exit char 

214 I 

215 lENLPROC getline ; 

216 I 

217 getsecretline |PROC get secret line (TEXT VAR textline) : 

218 1 

219 1 TEXT VAR char ; 

220 I textline := ; 

221 I get start cursor position ; 

222 I get line very secret ; 

223 I IF char = esc 

224 I THEN get line little secret 

225 I FI ; 

226 I cursor to start position ; 

227 I out (del line cr If) . 

228 I 

229 getllneverysecret |get line very secret : 

230 I REP 

231 I inchar (char) ; 

232 I IF char = esc OR char = cr 

233 I THEN LEAVE get line very secret 

234 I ELIF char = rubout 

235 I THEN delete last char 

236 I ELIF char >= ** " 

237 I THEN textline CAT char ; 

238 1 out (**.") 

239 I ELSE out (bell) 

240 I FI 

241 I PER . 

242 1 

243 delete las tchar (delete last char : 

244 I IF LENGTH textline = 0 

245 I THEN out (bell) 

246 1 ELSE out (back blank back) ; 

247 I delete char (textline, LENGTH textline) 

248 I FI . 

249 I 

250 getlinelittlesecret jget line little secret : 

251 I cursor to start position ; 

252 I editget (textline, exit char) . 

253 I 

254 getstartcursorposition jget start cursor position : 

255 I INT VAR x, y; 

256 I get cursor (x, y) . 

257 I 
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358 cursortostartposition | cursor to start position : 
259 I cursor (x, y) . 

26@ I 

261 lENDPROC get secret line ; 

262 I 

263 lENDPACKET std transput ; 
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1 I 

2 localjnanagerpart2 | PACKET local manager part 2 DEFINES (» Autor: J.Liedtk© 

3 I (♦ Stand: 25.02.85 •> 

4 I list : 

5 I 

6 I 

7 I TEXT VAR file name, status text; 
3 I 

9 I 

10 list IPROC list : 

11 I 

12 I disable stop ; 

13 I DATASPACE VAR ds := nilspace ; 

14 I FILE VAR list file := sequential file (output, ds) ; 

15 I headline (list file, "list") ; 

16 I list (list file) ; 

17 I show (list file) ; 

18 I forget (ds) . 

19 I 

20 lENDPROC list ; 

21 I 

22 list IPROC list (FILE VAR f) : 

23 I 

24 I enable stop ; 

25 I begin list ; 

26 I putline (f, "") ; 

27 I REP 

28 I get list entry (file name, status text) ; 

29 I IF file name = **" 

30 I THEN LEAVE list 

31 I FI ; 

32 I write (f, status text + " -»»»»). 

33 I write (f, file name) ; 

34 I write (f, ""*'") ; 

35 I line (f) 

36 I PER . 

37 I 

38 lENDPROC list ; 

39 I 

40 lENDPACKET local manager part 2 ; 
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PACKET eumel coder part 1 (• Autor: U. 

Bartling •) 

DEFINES run, run again, 
insert, 

prot, prot off, 

check, check on, check off, 

warnings, warnings on, warnings off, 

help, bulletin, packets 



EUMEL 



CODER 



*) 
•) 
•) 

Zur Beschreibung des Coders siehe 
*) 

U. Bartling, J. Liedtke: EUMEL-Coder- Interface 



(« Stand der Dokumentation : 13.02.1986 
*) 

(» Stand der Implementation : 16.04.1986 
•) 

(• 

*) 

(* 

*) 

) 



(4HHHM» Globale Variable *mmmm») 
TEXT VAR object name; 
FILE VAR bulletin file; 

INT VAR hash table pointer, nt link, permanent pointer, param link, 
index, mode, word; 

BOOL VAR found, end of params; 



25/1 



eumel coder part 1 



25/1 



Zeile »•*• ELAN EUMEL 1.8 10.11.86 •»*»• eumel coder part 1 

39 i(* 

+ I •) 

40 j(» 1. Interface zum ELAN-Compiler 
+ I 10.04.1986 •) 

41 |(» 1.7.5.4 

I •) 

42 |(» 

+ I •) 

43 |(« Beschreibung der Tabellen (-groessen), 

I *) 

44 !(♦ internen Vercodung von Typen 
^ I •) 

45 |(« und Kennungen . 

I 

46 |(» Initialisieren und Beenden des Compilers, 

I •) 

47 |(» Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle 

I *) 

48 !(• 

I *) 

+ I «4»*«»4* ) 

50 I 

51 I 

52 I LET begin of hash table = 0 , 

53 1 end of hash table - 1023 , 

54 I 

55 I begin of permanent table = 22784 , 

56 I before first pt entry = 22784 , 

57 1 first permanent entry = 22785 , 

58 I end of permanent table = 32767 , 

59 I 

60 I wordlength = 1 , (• compile u n d run 
+ I time ♦) 

61 I two word length * 2 , 

62 I three word length = 3 , 

63 I 

64 I permanent param const = 10000 , 

65 I permanent param var = 20000 , 

66 I permanent proc op » 30000 , 

67 I permanent type » 30000 , 

68 I permanent row « 10 , 

69 I permanent struct = 11 , 

70 I permanent param proc = 12 , 

71 |(» permanent param proc end marker = 0 , ») 

72 I permanent type field » 0 , 

73 I 

74 1 ptt limit = 10000 , 

75 I begin of pt minus ptt limit « 12784 , 

76 I 

77 I void = 0 » 

78 I int = 1 , 

79 I real = 2 , 

80 I string = 3 , 

81 I bool = 5 , 

82 I bool result = 6 » 

83 I dataspace = 7 , 

84 I row = 10 , 

85 I struct = 11 ♦ 

86 I 
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87 I const = 1 , 

88 I var = 2 , 

89 |{» proc = 3 , •) 

90 |(* denoter = 5 , ») 

91 1 bold = 2 , 

92 I 

93 I ins = TRUE , 

94 I no ins = FALSE , 

95 I no 1st = FALSE . 

96 I sermon = TRUE , 

97 I no sermon = FALSE , 

98 I 

99 I run a^ain mode = 0 , 

100 I compile file mode = 1 , 

101 I 

102 I warning message = 2 , 

103 I error message = 4 , 

104 I 

105 I point line = ** ; 

106 1 

107 I INT CONST permanent packet := -2 , 

108 I permanent end := -3 ; 

109 I 

110 I 

111 I INT VAR run again mod nr := © ; 

112 I 

113 I 

114 I Start/Ende <mmmm») 

115 I 

116 elan I PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line, 

117 I INT VAR start module number, BOOL CONST ins, 1st, rtc, 
+ I ser) : 

118 I EXTERNAL 256 

119 lENDPROC elan ; 

120 I 

121 I Hash/Namenstabelle «»»»**») 

122 I . 

123 nexthashentry [next hash entry : 

124 I hash table pointer INCR wordlength . 

125 I 

126 endofhashtablereached |end of hash table reached : 

127 I hash table pointer > end of hash table . 

128 I 

129 yetanotherntentry |yet another nt entry : 

130 I nt link := cdb int (nt link) ; 

131 I nt link <> 0 . ; 

132 I 

133 declareobject |PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) : 

134 I EXTERNAL 10031 

135 lENDPROC declare object ; I 

136 I 
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137 toobject |PROC to object (TEXT CONST seaxched object) : 

138 I hash ; 

139 I search nt entry . 

140 I 

141 hash I hash : 

142 I hash code := 0 ; 

143 I FOR index FROM 1 UPTO LENGTH searched object REP 

144 I addmult cyclic 

145 I ENDREP . 

146 I 

147 addmultcyclic | addmult cyclic : 

148 I hash code INCR hash code ; 

149 I IF hash code > end of hash table THEN wrap around FI ; 

150 I hash code := (hash code + code (searched object SUB index)) MOD 
+ I 1024 . 

151 I 

152 wraparound [wrap around : 

153 I hash code DECR end of hash table . 

154 I 

155 hashcode jhash code : nt link . 

156 I 

157 searchntentry [search nt entry : 

158 I found := FALSE ; 

159 I WHILE yet another nt entry REP 

160 I read current entry ; 

161 I IF object name = searched object 

162 j THEN found := TRUE ; 

163 I LEAVE to object 

164 I FI 

165 I PER . 

166 I 

167 readcurrententry |read current entry : 

168 I permanent pointer := cdb int (nt link + wordlength) ; 

169 I object n&me := cdb text (nt link + two word length) 

170 lENDPROC to object ; 

171 I 

172 I 

173 I (»••»♦ Permanent Tabelle •»•«») 

174 I . 

175 nextprocedure |next procedure : 

176 I permanent pointer := cdb int (permanent pointer) . ; 

177 I 

178 nextptparam | PROC next pt param : 

179 I mode := cdb int (param link) MOD ptt limit ; 

180 I param link INCR wordlength ; 

181 j IF mode = permanent row THEN skip over permanent row 

182 I ELIF mode = permanent struct THEN skip over permanent struct 

183 I FI ; 

184 I set end marker if end of list . 

185 I 
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186 skipoverpermanentrow |skip over permanent row : 

187 I param link INCH wordlength ; 

188 I next pt param . 

189 I 

190 skipoverpermanentstruc jskip over permanent struct : 

191 I REP 

192 I next pt param ; 

193 I mode := cdb int (param link) 

194 I UNTIL mode = permanent type field PER ; 

195 I param link INCR wordlength 

196 lENLPROC next pt param ; 

197 I 

198 setendmarkerifendoflis ...|PROC set end marker if end of list : 

199 I mode := cdb int (param link) ; 

200 I end of params := mode >= permanent proc op OR mode <= 0 

201 lENDPROC set end marker if end of list ; 

202 I 

203 gettypeandmode |PROC get type and mode (INT VAR type) : 

204 I mode := cdb int (param link) ; 

205 I IF mode = permanent param proc THEN type of param proc 

206 I ELSE type of object 

207 I FI . 

208 I 

209 typeofparamproc I type of param proc : 

210 I param link INCR wordlength ; 

211 I get type and mode (type) ; 

212 I mode := permanent param proc . 

213 I 

214 typeof object I type of object : 

215 I IF mode < 0 THEN type := 2769 + (32767 + mode) ; 

216 I mode := 0 

217 j ELSE type := mode MOD ptt limit ; 

218 I mode DECR type ; 

219 I translate type if necessary ; 

220 I translate mode if necessary 

221 I FI . 

222 I 

223 translatetypeifnecessa | translate type if necessary : 

224 I IF permanent row or struct THEN translate type FI . 

225 I 

226 translatetype [translate type : 

227 I type := param link - begin of pt minus ptt limit . 

228 I 

229 translatemodeifnecessa | translate mode if necessary : 

230 I IF mode = permanent parcun const THEN mode :> const 

231 I ELIF mode = permanent param var THEN mode := var 

232 I FI . 

233 I 

234 permanentroworstruct [permanent row or struct : 

235 I type « permanent row OR type ■ permanent struct 

236 lENDPROC get type and mode ; 
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237 I 

238 I 

239 I (»•♦«♦ Allgemeine Zugriffsprozeduren *hmm»») 

240 1 

241 cdbint |INT PROC cdb int (INT CONST index) : 

242 I EXTERNAL 116 

243 lENDPRCX: cdb int ; 

244 I 

245 cdbtext |TEXT PROC cdb text (INT CONST index) : 

246 I EXTERNAL 117 

247 lENDPROC cdb text ; 

248 I 
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251 |(« 

+ I •) 

252 |(» 10. Inspector 
+ I 16.04.1986 •) 

253 |(» 

I *) 

-f I «-»«»»« ) 

255 I 

256 I 

257 I 

258 I INT VAR line number, pattern length, packet link, 

259 I begin of packet, last packet entry, indentation; 

260 I 

261 I TEXT VAR bulletin name, type and mode, pattern, buffer; 

262 I 

263 IDATASPACE VAR bulletin ds :: nilspace ; 

264 I 

265 I . packet name : 

266 I cdb text (cdb int( packet link + wordlength) + two word length) . 

267 I 

268 I .within editor : 

269 I aktueller editor > 0 . ; 

270 j 

271 nameoftype jPROC name of type (INT CONST type) : 

272 I SELECT type OP 

273 I CASE void : 

274 I CASE int : type and mode CAT "INT** 

275 I CASE real : type and mode CAT "REAL" 

276 j CASE string : type and mode CAT "TEXT" 

277 I CASE bool, bool result : type and mode CAT "BOOL" 

278 I CASE dataspace : type and mode CAT "DATASPACE" 

279 I CASE row : type and mode CAT "ROW " 

280 I CASE struct : type and mode CAT "STRUCT" 

281 I OTHERWISE : complex type 

282 I ENDSELECT . 

283 I 

284 complextype | complex type : 

285 I IF type > ptt limit THEN perhaps permanent struct or row 

286 I ELSE get complex type 

287 in. 

288 I 

289 perhapspermanentstruct [perhaps permanent struct or row : 

290 I index := type -»■ begin of pt minus ptt limit ; 

291 I mode := cdb int (index) MOD ptt limit ; 

292 I IF mode = permanent row THEN get permanent row 

293 I ELIF mode = permanent struct THEN get permanent struct 

294 I ELSE type and mode CAT "-" 

295 I FI . 

296 1 

297 getcomplextype |get complex type : 

298 I index := type + begin of permanent table ; 

299 I IF is complex type THEN get name 

300 I ELSE type and mode CAT "-" 

301 I FI . 
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302 I 

303 iscoraplextype |is complex type : 

304 I permanent type definition mode = permanent type . 

305 I 

306 getname jget name : 

307 I type and mode CAT cdb text (link to type name ♦ two word 
+ I length) . 

308 I 

309 linktotypename jlink to type name : 

310 I cdb int (index + three word length) . 

311 I 

312 permanenttypedef initio [permanent type definition mode : 

313 I cdb int (index + wordlength) . 

314 I 

315 getpermanentrow |get permanent row : 

316 I INT VAR t; 

317 I type and mode CAT **ROW " ; 

318 1 type and mode CAT text (cdb int (index + wordlength)) ; 

319 I type and mode CAT " " ; 

320 I param link := index + two wordlength ; 

321 I get type and mode (t) ; 

322 I name of type (t) . 

323 i 

324 getpermanentstruct jget permanent struct ; 

325 I type and mode CAT "STRUCT ( ... )" 

326 lENDPROC name of type ; 

327 I 

328 help IPROC help (TEXT CONST proc name) : 

329 I prep bulletin ; 

330 I prep help ; 

331 I scan (object name) ; 

332 I next symbol (pattern) ; 

333 I packet link := end of permanent table ; 

334 I IF function = 0 THEN standard help 

335 I ELSE asterisk help 

336 I FI . 

337 I 

338 prephelp Iprep help : 

339 I object name := compress (proc name) ; 
34© I INT VAR function : : 0 ; 

341 I INT CONST 1 : : LENGTH object najne ; 

342 I IF 1 > 1 AND object name <> 

343 I THEN IF (object name SUB 1) » 

344 I THEN function INCR 2 ; 

345 I delete char (object name, 1) 

346 I FI ; 

347 I IF (object name SUB 1) - 

348 I THEN function INCR 1 ; 

349 I delete char (object name, 1) 

350 I FI ; 

351 I IF another asterisk THEN wrong function FI 

352 I FI . 

353 I 
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354 anotherasterlsk | another asterisk : 

355 I pos (object name, **•**) <> 0 . 

356 I 

357 wrongf unction |vnrong function : 

358 I errorstop ( "unzulaessige Sternfunktion") . 

359 I 

360 standardhelp {standard help : 

361 I to object (pattern) ; 

362 j IF found THEN display 

363 I ELSE error stop ( "unbekannt: " + proc name) 

364 I FI . 

365 I 

366 display j display : 

367 I WHILE permanent pointer <> 0 REP 

368 I put name of packet if necessary ; 

369 I put specifications (pattern) ; 

370 I next procedure 

371 I ENTREP ; 

372 I show bulletin file . 

373 I 

374 putnameofpacketifneces |put name of packet if necessary : 

375 j IF new packet THEN packet link :<= permanent pointer ; 

376 I find begin of packet ; 

377 I writeline (2) ; 

378 I write packet name 

379 I FI . 

380 I 

381 findbeginofpacket jfind begin of packet : 

382 I REP 

363 I packet link DECR wordlength 

384 I UNTIL begin of packet found PER . 

385 I 

386 beglnof packet found | begin of packet found : 

387 I cdb int (packet link) = permanent packet . 

388 I 

389 newpacket jnew packet : 

390 I permanent pointer < packet link . 

391 I 

392 asteriskhelp (asterisk help : 

393 I hash table pointer := begin of hash table ; 

394 I pattern length := LENGTH pattern - 1 ; 

395 I REP 

396 I list all objects in current hash table chain ; 

397 I next hash entry 

398 I UNTIL end of hash table reached ENDREP ; 

399 I show bulletin file . 

400 I 

401 listallobjectsincurren jlist all objects in current hash table chain : 

402 I nt link := hash table pointer ; 

403 I WHILE yet another nt entry REP 

404 I permanent pointer := cdb int (nt link + wordlength) ; 

405 I object name := cdb text (nt link + two word length) ; 

406 I IF matching THEN into bulletin FI 
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407 I PER . 

408 I 

409 matching | matching : 

410 1 INT CONST p :: pos (object name, pattern) ; 

411 I SELECT function OF 

412 I CASE 1 : p <> 0 AND p = LENGTH object name - pattern 
+ I length 

413 I CASE 2 : p = 1 

414 I CASE 3 : p <> 0 

415 I OTHERWISE FALSE 

416 I ENDSELECT . 

417 I 

418 intobulletin |into bulletin : 

419 I object names into bulletin (BOOL PROC not end of chain) 

420 lENLPROC help ; 

421 I 

422 notendof chain |BOOL PROC not end of chain : 

423 I permanent pointer <> 0 

424 lENDPROC not end of chain ; 

425 I 

426 writepacketname | PROC write packet name : 

427 I indentation := 0 ; 

428 I write line ; 

429 I write bulletin line ("PACKET ") ; 

430 I indentation :» 7 ; 

431 I object name := packet name ; 

432 I write bulletin line (object name) ; 

433 I write bulletin line (**:") ; 

434 I writeline (2) 

435 lENDPROC write packet name ; 

436 I 

437 putspecifications |PROC put specifications (TEXT CONST proc name) : 

438 I put obj name (proc name) ; 

439 I to first param ; 

440 I IF NOT end of params THEN put param list FI ; 

441 I put result ; 

442 I writeline . 

443 I 

444 tofirstparam |to first param : 

445 I param link := permanent pointer word length ; 

446 I set end marker if end of list . 

447 I 

448 putresult jput result : 

449 1 INT VAR type; 

450 I get type and mode (type) ; 

451 I IF type <> void THEN type and mode := " -->**; 

452 I name of type (type) ; 

453 1 write bulletin line (type and mode) 

454 I FI 

455 lENDPROC put specifications ; 

456 I 
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457 putparamlist jPROC put param list : 

458 I write bulletin line (" ; 

459 I REP 

460 I INT VAR type, param mode; 

461 I get type and mode (type) ; 

462 I param mode := mode ; 

463 I put type and mode ; 

464 I maybe param proc ; 

465 I next pt param ; 

466 I IF end of params THEN write bulletin line ; 

467 I LEAVE put param list 

468 I FI ; 

469 I write bulletin line **) ; 

470 I PER . 

471 I 

472 puttypeandmode jput type and mode : 

473 I type and mode := ; 

474 I name of type (type) ; 

475 I type and mode CAT name of mode ; 

476 I write bulletin line (type and mode) . 

477 I 

478 nameofmode |name of mode : 

479 I IF param mode = const THEN " CONST*' 

480 I ELIF param mode = var THEN ** VAR" 

481 I ELSE " PROC" 

482 I FI . 

483 I 

484 maybeparamproc | maybe param proc : 

485 I IF mode = permanent param proc THEN put virtual params FI . 

486 I 

487 putvirtualparams |put virtual params : 

488 I skip over result type if complex type ; 

489 I IF NOT end of virtual params THEN put param list FI. 

490 I 

491 skipoverresulttypeifco |skip over result type if complex type : 

492 I next pt param . 

493 I 

494 endofvirtualparams |end of virtual params : 

495 I end of params 

496 lENDPROC put param list ; 

497 I 

498 nextpacket |PROC next packet : 

499 I REP 

500 I packet link INCR wordlength ; 

501 I word := cdb int (packet link) ; 

502 I IF word = permanent packet THEN true return 

503 I ELIF end of permanents THEN false return 

504 I FI ; 

505 I ENDREP . 

506 I 

507 truereturn |true return : 

508 I found := TRUE ; 

509 I LEAVE next packet . 
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510 

511 
512 
513 
514 

515 
516 
517 
518 



519 
520 
521 
522 
523 
524 
525 
526 



527 
528 
529 
530 
531 
532 
533 
534 



535 
536 
537 
538 
539 



540 
541 
542 
543 
544 
545 
546 
547 



548 
549 
550 
551 
552 
553 
554 
555 
556 
557 
558 



falsereturn 



endofpermanents 



prepbulletin 



showbulletinfile 



writebulletinline 



writeline 



writelino 



false return : 

found := FALSE ; 
LEAVE next packet 



end of permanents : 

word = permanent end OR packet link 
ENDPROC next packet ; 



end of permanent table 



PROC prep bulletin : 

forget (bulletin ds) ; 
bulletin ds := nilspace ; 

bulletin file := sequential file (output, bulletin ds) ; 
line number := 0 ; 
buffer := 
ENDPROC prep bulletin ; 



PROC show bulletin file : 

IF within editor THEN ueberschrift neu FX ; 

DATASPACE VAR local ds : : bulletin ds ; 

FILE VAR local file :: sequential file (modify, local ds) 

show (local file) ; 

forget (local ds) 
ENDPROC show bulletin file ; 



PROC write bulletin line (TEXT CONST line) : 

IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ; 

buffer CAT line 
ENDPROC write bulletin line ; 



PR(DC writeline : 

write (bulletin file, buffer) 

line (bulletin file) ; 

line number INCR 1 ; 

cout (line number) ; 

buffer := indentation » " " 
ENDPROC writeline ; 



PROC writeline (INT CONST times) 
IF LENGTH compress (buffer) < 



FI ; 

line (bulletin file, index) 
line number INCR index; 
indentation := 0 ; 
cout (line number) 
ENDPROC writeline ; 



0 THEN index := times - 1 
writeline 
ELSE Index times 
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559 bulletin |PROC bulletin (TEXT CONST packet name) : 

560 I prep bulletin ; | 

561 I scan (packet name) ; 

562 I next symbol (pattern) ; 

563 I to packet ; 

564 I IF found THEN list packet ; 

565 I show bulletin file 

566 I ELSE error stop (packet name + ** ist kein Paketname") 

567 I FX . 

568 I 

569 topacket jto packet : 

570 I last packet entry := 0 ; 

571 I get name tab link of packet name ; 

572 I packet link := before first pt entry ; 

573 I REP 

574 I packet link INCH wordlength ; 

575 I word := cdb int (packet link) ; 

576 I IF word < 0 THEN IF word = permanent packet THSU packet 
+ I found 

577 I ELIF word =* permanent end THEN return 

578 I FI 

579 I FI 

580 I ENDREP . 

581 I 

582 getnametablinkof packet jget nametab link of packet name : 

583 I to object (pattern) ; 

584 I IF NOT found THEN error stop ( "unbekanntes Paket + packet 
+ I name) ; 

585 I LEAVE to packet 

586 I FI . 

587 I 

588 packetfound j packet found : 

589 I IF cdb int (packet link + wordlength) = nt link 

590 I THEN last packet entry ;= packet link FI . 

591 I 

592 return i return : 

593 I IF last packet entry <> 0 THEN found := TRUE ; 

594 I packet link := last packet entry 

595 I ELSE found := FALSE 

596 I FI ; 

597 I LEAVE to packet 

598 lENLPROC bulletin ; 

599 I 

600 listpacket |PROC list packet : 

601 I begin of packet := packet link + word length ; 

602 I write packet name ; 

603 I find end of packet ; 

604 I run through nametab and list all packet objects . 

605 1 

606 findendof packet jfind end of packet : 

607 I last packet entry := begin of packet ; 

608 I REP 

609 I last packet entry IN(3R wordlength ; 

610 I word := cdb int (last packet entry) ; 

611 I UNTIL end of packet entries PER . 
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612 I 

613 endofpacketentries |end of packet entries : 

614 I word = permanent packet OR word = permanent end . 

615 I 

616 runthroughnametabandli jrun through nametab and list all packet objects : 

617 I hashtable pointer := begin of hashtable ; 

618 I REP 

619 I nt link := hashtable pointer ; 

620 I list objects of current packet in this chain ; 

621 I next hash entry 

622 I UNTIL end of hashtable reached ENDREP . 

623 I 

624 listobjectsofcurrentpa |list objects of current packet in this chain : 

625 I WHILE yet another nt entry REP 

626 I permanent pointer :- cdb int (nt link + wordlength) ; 

627 I put objects of this name 

628 I PER . 

629 I 

630 putobjectsofthisname |put objects of this name : 

631 I IF there is at least one object of this name in the current 
+ I packet 

632 I THEN into bulletin FI . 

633 I 

634 therei sat leas toneobjec | there is at least one object of this name in the current packet : 

635 I REP 

636 I IF permanent pointer >= begin of packet AND 

637 I permanent pointer < last packet entry 

638 I THEN LEAVE there is at least one object of this name 

639 I in the current packet WITH TRUE FI ; 

640 I next procedure 

641 I UNTIL permanent pointer = 0 PER ; 

642 I FALSE . 

643 I 

644 intobulletin jinto bulletin : 

645 I object name := cdb text (nt link ■»■ two word length) ; 

646 I object names into bulletin (BOOL PROC within packet) 

647 lENDPROC list packet ; 

648 I 

649 withinpacket |BOOL PROC within packet : 

650 I permanent pointer >» begin of packet AND 

651 I permanent pointer < last packet entry 

652 lENDPROC within packet ; 

653 I 

654 objectnamesintobulleti ...|PROC object names into bulletin (BOOL PRCX; link ok) : 

655 I scan (object name) ; 

656 I next symbol (object name, mode) ; 

657 I IF type definition THEN put type definition 

658 I ELSE put object definitions 

659 I FI . 

660 I 
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661 typedefinition |type definition : 

662 I mode = bold AND no params . 

663 I 

664 noparams |no params : 

665 I cdb int (permanent pointer + word length) >= permanent type . 

666 I 

667 puttypedefinition jput type definition : 

668 I put obj name (object name) ; 

669 I write bulletin line (^^TYPE ; 

670 I writeline (1) . 

671 I 

672 putobjectdefinitions |put object definitions : 

673 I WHILE link ok REP 

674 I put specifications (object name) ; 

675 I next procedure 

676 I ENDREP 

677 lENDPROC object names into bulletin ; 

678 I 

679 bulletin |PROC bulletin : 

680 I prep bulletin ; 

681 I packet link := first permanent entry ; 

682 I REP 

683 I list packet ; 

684 I write line (4) ; 

685 I noxt packet 

686 I UNTIL NOT found PER ; 

687 I show bulletin file 

688 lENDPROC bulletin ; 
669 I 

690 putobjname |PROC put obj name (TEXT CONST name) : 

691 I buffer := " ; 

692 I bulletin neune := point line ; 

693 I change (bulletin name, 1, end of line or name, name) ; 

694 I buffer CAT bulletin name ; 

695 I indentation := LENGTH buffer + 1 . 

696 I 

697 endoflineorname |end of line or name : 

698 I min (LENGTH name, LENGTH bulletin name) 

699 lENDPROC put obj name ; 

700 I 

701 packets I PROC packets : 

702 I prop bulletin ; 

703 I packet link := first permanent entry ; 

704 I REP 

705 I object name := packet name ; 

706 I put obj name (object name) ; 

707 I write line ; 

708 I next packet 

709 I UNTIL NOT found PER ; 

710 I show bulletin file 

711 lENDPROC packets ; 

712 I 
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I 

715 |(* 

I *) 

716 |(* 11. ELAN Run-Interface 
+ I 09.01.1986 •) 

717 i(* 

I •) 

718 I ( ♦ Uebersetzen von ELAN -Programme n 

I *) 

719 |(» Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler 

I •) 

720 |(» 

I •) 

■f I IHHHHHt ) 

722 I 

723 I 

724 I 

725 I BOOL VAR list option := FALSE , 

726 I check option := TRUE , 

727 I warning option := FALSE » 

728 I listing enabled := FALSE ; 

729 I 

730 I FILE VAR listing file ; 

731 I 

732 I TEXT VAR listing file name := ; 

733 I 

734 I 

735 run |PROC run (TEXT CONST file name) : 

736 I enable stop ; 

737 I IF NOT exists (file name) 

738 I THEN errorstop + file name + gibt es nicht**) 

739 I FI ; 

740 I last param (file name) ; 

741 I run elan (file name» no ins) 

742 I END PROC run; 

743 I 

744 run | PROC run : 

745 I run (last param) 

746 lENDPROC run ; 

747 I 

748 runagain |PR(XJ run again : 

749 I IF run again mod nr <> 0 

750 I THEN elan (run again mode, bulletin file, run again mod nr, 

751 I no ins, no 1st, check option, no sermon) 

752 I ELSE errorstop (*"run again' nicht moeglich") 

753 I FI 

754 lENDPROC run again ; 

755 I 

756 insert |PROC insert (TEXT CONST file name) : 

757 I enable stop ; 

758 I IF NOT exists (file name) 

759 I THEN errorstop + file name + gibt es nicht") 
25/16 eumel coder part 1 25/16 



Zelle 



ELAN EUMEL 1.8 •»•• 10.11.86 eumel coder part 1 



760 I FI ; 

761 I last param (file name) ; 

762 I run elan (file name, ins) 

763 lENDPROC insert ; 

764 I 

765 insert |PROC insert : 

766 I insert (last param) 

767 lENDPROC insert ; 

768 I 

769 runeUn |PROC run elan (TEXT (XNST file name, BOOL CONST insert option) : 

770 I FILE VAR source := sequential file (modify, file name) ; 

771 I IF listing enabled 

772 I THEN open listing file 

773 I FI ; 

774 1 

775 I disable stop ; 

776 I no do again ; 

777 I elan (compile file mode, source, , run again mod nr, 

778 I insert option, list option, check option, sermon) ; 

779 I 

78© I IF anything noted AND command dialogue 

781 I THEN ignore halt during compiling ; 

782 1 note edit (source) ; 

783 I last param (file name) ; 

784 I errorstop (*"*) 

785 I FI . 

786 I 

787 ignorehaltduringcompil | ignore halt during compiling : 

788 I IF is error 

789 I THEN put error ; 

790 I clear error ; 

791 I pause (5) 

792 I FI . 

793 I 

794 openlistingfile |open listing file : 

795 I listing file := sequential file (output, listing file name) ; 

796 I max line length (listing file, 130) 

797 I 

798 lENDPROC run elan ; 

799 I 

800 outtext IPROC out text (TEXT CONST text, INT CONST out type) : 

801 1 INTERNAL 257 ; 

802 I IF online 

803 I THEN out (text) 

804 1 FI ; 

805 I IF out type = error message OR (warning option AND out type = 
■t- I warning message) 

806 I THEN note (text) ; 

807 I PI ; 

808 I IP listing enabled 

809 I THEN write (listing file, text) 

810 1 FI 

811 lENDPROC out text ; 

812 I 
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813 outline |PROC out line (INT CONST out type) : 

814 I INTERNAL 258 ; 

815 I IF online 

816 1 THEN out ( *»**13*"'10'"') 

817 I n ; 

818 I IF out type = error message 

819 I OR (warning option AND out type = warning message) 

820 I THEN note line 

821 1 ELIF listing enabled 

822 I THEN line (listing file) 

823 I FI 

824 lENDPROC out line ; 

825 I 

826 prot IPROC prot (TEXT CONST file name) : 

827 I list option := TRUE ; 

828 I listing file name := file name ; 

829 I listing enabled := TRUE 

830 lENDPROC prot ; 

831 I 

832 protof f I PROC prot off : 

833 i list option := FALSE ; 

834 I listing enabled := FALSE 

835 lENDPROC prot off ; 

836 I 

837 prot I BOOL PROC prot : 

838 I list option 

839 lENDPROC prot ; 

840 I 

841 checkon | PROC check on : 

842 I check option := TRUE 

843 lENDPROC check on ; 

844 I 

845 checkoff |PROC check off : 

846 I check option := FALSE 

847 lENDPROC check off ; 

848 I 

849 check |BOOL PROC check : 

850 I check option 

851 lENDPROC check ; 

852 I 

853 warningson |PROC warnings on : 

854 I warning option := TRUE 

855 lENDPROC warnings on ; 

856 I 
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857 warningsoff |PRCX: warnings off : 

858 I warning option := FALSE 

859 lENDPROC warnings off ; 

860 I 

861 warnings |BOOL PROC warnings : 

862 I warning option 

863 lENDPROC warnings ; 

864 I 

865 lENDPACKET eumel coder part 1 ; 
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1 |(* VERSION 2 06.03.86 

2 mathlib | PACKET mathlib DEFINES sqrt, exp, In, log2, logl0, e, pi, 

3 I sin, cos, tan, sind, cosd, tand, 

4 I arctan, arc tand, random, initializerandom 

5 I 

6 I LET pii = 3.141592653589793238462, 

7 I pi2 = 1.570796326794896619231, 

8 I pi3 = 1.047197551196597746154, 

9 I pi6 = 0.523598775598298873077, 

10 I pi4 = 1.273239544735162686151, 

11 I ln2 = 0.693147180559945309417, 

12 I lg2 = 0.301029995663981195213, 

13 I lnl0 = 2.302585092994045684018, 

14 I Ige = 0.434294481903251827651, 

15 I ei = 2.718281828459045235360, 

16 I pil80 = 57.295779513082320876798, 

17 I sqrt3 = 1.732050807568877293527, 

18 I sqr3 = 0.577350269189625764509, 

19 I sqr3p2= 3.732050807568877293527, 

20 I sqr3m2= 0.267949192431122706473, 

21 I sqr2 = 0.707106781186547524400; 

22 I 

23 I REAL VAR rdg: : 0.4711; 

24 I 

25 pi IREAL PROC pi: pii END PROC pi; 

26 e iREAL PROC e : ei END PROC e; 

27 I 

28 In IREAL PROC In ( REAL CONST x ): 

29 I log2(x) * ln2 

30 I END PROC In; 

31 I 

32 logl0 IREAL PROC logl0( REAL CONST x ): 

33 I log2(x) • 1^2 

34 I END PROC logl0; 

35 I 

36 log2 I REAL PROC log2 ( REAL CONST z ) : 

37 I REAL VAR t, summe::0.0, x::z; 

38 I IF x=1.0 THEN 0.0 

39 I ELIF x>0.0 THEN normal 

40 I ELSE error s top (*'log2: " + text {x,20)); 0.0 FI. 

41 I 

I 

42 normal | normal : 

43 I IF X >= 0.5 THEN normalise downwards 

44 I ELSE normalise upwards FI; 

45 I IF X < sqr2 THEN summe := sumrae - 0.75; t := transS 

46 I ELSE summe := summe - 0.25; t := trans2 FI; 

47 I summe reihenentwicklung. 

48 I 
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49 normal isedownwajrds 

50 

51 

52 

53 normaliseupwards 

54 

55 

56 

57 transS 

58 trans2 
59 

60 reihonentwicklung 

-»- 
61 
62 
63 



64 sqrt 

65 
66 
67 
68 
69 
70 

71 nontrivial 

72 

73 

74 

75 

76 

77 

78 

79 

80 

81 

82 



83 exp 

84 
85 
86 
87 
88 
89 
90 
91 
92 

93 approx 

94 

95 

96 

97 

98 

99 



1.8 *••• 10.11.86 mathlib 



normalise downwards: 
WHILE X >= 8.0 REP 
WHILE X >= 1.0 REP 



0.0625 • x; summe:=summe+4.0 PER; 
0.5 • x; summe: =summe+1.0 PER. 



normalise upwards: 
WHILE x< =0.0625 REP x 
WHILE x<= 0.5 REP x := 



16.0 » x; summe: =summe-4.0 PER; 
2.0 * x; summe := summe -1.0 



trans8: (x - 0. 5946035575013605 )/(x + 0.5946035575013605). 
trans2: (x - 0. 8408964152537145 )/(x 0.8408964152537145). 



reihenentwicklung: x := t » t; 



t • 0.06405572387119384648 



(((((( 3 . 465»x+4 . 095 ) *x+5 . 005 ) •x+e . 435 ) *»x+9 . 009 ) •x+15 . 015 ) ♦x+45 . 045 )| 
END PROC log2; 



REAL PROC sqrt ( REAL CONST z ): 
REAL VAR y0, yl, x: :z; 
INT VAR p :: decimal exponent(x) DIV 2; 
IF p <= -64 THEN 0.0 

ELIF X < 0.0 THEN err or s top sqrt: + text (x,20)); 0.0 
ELSE nontrivial FI. 



nontrivial: 
set exp (decimal exponent (x) -p-p, x) ; 
IF x<10.0 THEN X := 5.3176703 - 40.760905/( 8.408065 + x ) 

ELSE X := 16.81595 - 1288.973 /( 84.08065 + x ) FI; 

y0 := x; 

set exp (decimal exponent (x) + p, y0); 

yl 

y0 

yl 

END PROC sqrt; 



0.5 » 


y0 


+ z/y0 ); 


0.5 • 


yl 


+ z/yl ); 


0.5 » 


y© 


+ z/y0 ); 


0.5 ♦ 


yl 


+ z/yl ) 



REAL PROC exp ( REAL CONST z ): 
REAL VAR x::z, a::1.0; BOOL VAR negativ :: x<0.0; 
IF negativ THEN x := -x FI; 

IF x> 292. 42830676 

THEN IF NOT negativ THEN errorstop ( **REAL-Ueberlauf " ) FI ; 0.0 
ELIF x< =0.0001 

THEN ( 0.5»z + 1.0 ) * z + 1.0 

ELSE approx 
FI. 



approx : 
IF X > lni0 
THEN X := lge*»x; 
a := 1 ^, 

set exp (int(x) , a) ; 
X := frac(x)*lnl0 

FI; 
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146 sin I REAL PROC sin ( REAL CONST x ): 

147 I REAL VAR y, r, q; 

148 I IF X < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI; 

149 I y := y • Pi4; 

150 I r := floor(y); 

151 I sincos( q+r , y-r ) 

152 I END PROC sin; 

153 I 

154 sind I REAL PROC sind ( REAL CONST x ): 

155 I REAL VAR y, r, q; 

156 I IF X < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI; 

157 I y := y / 45.0; 

158 I r := floor(y); 

159 I sincos( q+r , y-r ) 

160 lEND PROC sind; 

161 i 

162 cos I REAL PROC cos ( REAL CONST x ): 

163 I REAL VAR y, q; 

164 I IF X < 0.0 THEN y := -x ELSE y := x FI; 

165 I y := y * pi4; 

166 I q := floor(y); 

167 I sincos( q+2.0, y-q ) 

168 I END PROC cos; 

169 I 

17© C03d I REAL PROC cosd ( REAL CONST x ): 

171 I REAL VAR y, q; 

172 I IF X < 0.0 THEN y := -x ELSE y := x FI; 

173 I y := y / 45.0; 

174 I q •= floor(y) ; 

175 I sincos( q+2.0, y-q ) 

176 I END PROC cosd; 

177 I 

178 sincos I REAL PROC sincos ( REAL CONST q. y ): 

179 I REAL VAR r :: q - floor( 0.125»q + 0.1 ) * 8.0; 

100 I IF r >= 4.0 THEN IF r >= 6.0 THEN IF r >= 7.0 THEN - sin 

+ I approx( 1.0-y) 

I ELSE - cos approx(y) 

I 

^Q2 ELSE IF r >* 5.0 THEN - cos 

+ I approx( 1.0-y) 

-1^33 I ELSE - sin approx(y) 

^ I FI FI 

134 I ELSE IF r >= 2.0 THEN IF r >= 3.0 THEN sin 
+ I approx( 1.0-y) 

135 I ELSE cos approx(y) 

I FI 

13g I ELSE IF r >= 1.0 THEN cos 

+ I approx(1.0-y) 

13-7 I ELSE sin approx(/ 

^ j FI FI FI 

188 I END PROC sincos; 

189 1 
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cosapprox 



arctand 



REAL PROC sin approx ( REAL CONST x ) : 
REAL VAR z: :x*x; 

x«( ( ( ( ( (0. 68771015405930356-11*2-0. 1757149296873372e-8)«2+0. 313 
3616216672568 

e -6 ) »z-0 . 36576204158458916-4 ) *z+0 . 2490394570188737e-2 ) •z-© . 8074 
551218826-1)* 
z+0. 7853981633974483) 
END PROC sin approx; 



REAL PROC cos approx ( REAL CONST x ): 
REAL VAR z: :x*x; 

(((((( -0.38577618645602766-12*z+0. 1150049701781416-9 )*2-0. 24611 
36382674196-7 

) -z+O . 35908604458857486-5 ) *z-0 . 3259918869266875e-3) "z*© . 1585434 
4243815416-1) 
•z-0 . 3084251375340425 ) *z+l . 0 
END PROC cos approx; 



REAL PROC arc tan ( REAL CONST y ) : 
REAL VAR f, z, x; BOOL VAR neg :: y < ©.©; 
IF neg THEN x := -y ELSE x := y FI; 
IF x>l.© THEN f := a ELSE f := -b; neg := NOT neg FI; 
z : = X * x; 

X : = x/( ( ( ( ( ( (0.©107090276046822*z-0. 0164775718210804© )*2 

+© . 02177846332482151 ) *z-0 . 03019339673273880 ) *z+0 . 04656©835 
61183398 )*z 

-0 . 0888888888888888 ) »z+0 . 3333333333333333) *z+l . 0 ) ; 
IF neg THEN x - f ELSE f - x FI. 



a: IF x>sqr3p2 THEN x := 1.0/x; pi2 ELSE x 
4.0/(sqrt3+x+x+x)-sqr3; pi3 FI. 



b:IF x<sqr3ni2 THEN 0.0 
pi6 FI 
END PROC arc tan; 



ELSE X := sqrt3 - 4.0/(sqrt3+x) ; 



REAL PROC arctand ( REAL CONST x ) : 

arctan(x) * pi 18© 
END PROC arctand; 



REAL OP *• ( REAL CONST b, 6 ) : 
IF b=0.© 

THEN IF 6=0.0 THEN 1.0 ELSE 0.0 FI 
ELIF b < 0.0 

THEN 6rrorstop("(*'+text(b,20)+*') *» *'+t6xt(e)); (-b) ** e 
ELSE exp( 6 * Iog2( b ) * ln2 ) 
FI 

END OP *•; 
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230 I 

231 I REAL OP «• ( REAL CONST a, INT CONST b ) : 

232 I 

233 I REAL VAR p := 1.0 , 

234 I r := a ; 

235 I INT VAR n := ABS b , 

236 1 m ; 

237 I IF (a = 0.0 OR a = -0.0) 

238 I THEN IF b = 0 

239 I THEN 1.0 

240 I ELSE 0.0 

241 I FI 

242 1 ELSE WHILE n>© REP 

243 I m := n DIV 2 ; 

244 I IF m + m = n 

245 I THEN n : = m ; 

246 I r := r*r 

247 1 ELSE n DECR 1 ; 

248 I p := pr 

249 1 FI 

250 I END REP ; 

251 I IF b>0 

252 I THEN p 

253 I ELSE 1.0 / p 

254 I FI 

255 I FI . 

256 I 

257 I END OP ; 

258 I 

259 random |REAL PROC random: 

260 I 

+ I rdg:=rdg+pii;rdg:=rdg»rd«;rdg:=rdg»rdg;rdg:=rdg«rdg;rdg:«frac( 

+ I rdg);rdg 

261 I END PROC random; 

262 I 

263 initializerandom |PROC initializerandom ( REAL CONST z ): 

264 I rdg := frac(z) 

265 I END PROC initializerandom; 

266 I 

267 I END PACKET mathlib; 
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1 |;» VERSION 2 ©5.05.86 *) 

2 coirmandhandier | PACKET command handler DEFINES {» Autor: J.Liedtke *) 

3 i 

4- I get command , 

5 ; analyze command , 

6 I do command , 

7 i command error , 

8 I cover tracks : 

9 I 
1© I 

11 I LET cr If = ««4i,«^3»,«^g«« ^ 

12 I esc k = ""27"k" , 

13 I command pre = ''♦'4"'»i3*' ^ , 

14 I command post = ""IS'^'l©" ** , 

15 I 

16 I max command length = 201© , 

17 I 

18 I tag type = 1 , 

19 I texttype = 4 , 

20 I eof type = 7 ; 

21 I 

22 I 

23 ITEXT VAR command handlers own command line 

24 I previous command line :=*"*, 

25 I symbol , 

26 I procedure , 

27 I pattern , 

28 I error note :=****; 

29 I 

30 i INT VAR symbol type ; 

31 I 

32 1 

33 getcommand |PROC get command (TEXT CONST command text) : 

34 I 

35' I get command (command text, command handlers own command line) 

36 I 

37 lENDPROC get command ; 

38 I 

39 getcommand |PROC get command (TEXT CONST command text, TEXT VAR command line) : 

40 I 

41 I set line nr (0) ; 

42 1 error protocoll ; 

43 I get command from console . 

44 I 

45 errorprotocoll | error protocoll : 

46 I IF is error 

47 j THEN put error ; 

48 I clear error 

49 I ELSE command line :="**; 

50 I ri • 

51 I 

52 getcommandfromconsole jget command from console : 

53 I normalize cursor ; 

54 I REP 

55 I out (command pre) ; 

56 I out (command text) ; 
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57 ] out ( command post ) ; 

58 I editget command 

59 I UNTIL command line <> "''PER ; 

60 i param position (LENGTH command line) ; 

61 i out (command post) . 

62 I 

63 edltgetcommand | editget command : 

64 I TEXT VAR exit char ; 

65 I FEP 

66 I get cursor (x, y) ; 

67 I editget i command line, max command length, x size - x, 

68 I "k", exit char) ; 

69 I ignore halt errors during editget ; 

70 I break quiet if command line is too long ; 

71 I IP exit char = esc k 

72 I THEN cursor to begin of command input ; 

73 I command line : « previous command line 

74 I ELIF LENGTH command line > 1 

75 I THEN previous command line := command line ; 

76 I LEAVE editget command 

77 I ELSE LEAVE editget command 

78 I n 

79 I PER . 

8© ! 

61 normalizecursor | normalize cursor : 

82 I INT VAR x, y; 

83 I out (crlf) ; 

84 I get cursor (x, y) ; 

85 I cursor (x, y) . 

86 ! 

87 Ignorehal terror sduring [ignore halt errors during editget : 

88 I IF is error 

89 I THEN clear error 

90 j FI . 

91 I 

92 breakquietifcomroandlln | break quiet if command line is too long : 

93 I IF command line is too long 

94 I THEN command line ;= "break (quiet)** 

95 I FI . 

96 I 

97 coanandlineistoolong (command line is too long : 

96 I LENGTH command line = max conmand length . 

99 I 

100 cursortobeginof command | cursor to begin of command input : 

101 I out (command pre) . 

102 I 

103 jillSPROC get command ; 

104 I 

105 I 

106 analyzecomroand |PROC analyze command ( TEXT CONST command list, 

107 I INT CX)NST permitted type, 

108 I INT VAR command index, number of params, 

109 I TEXT VAR param 1, param 2) : 

110 I 
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111 I analyze command (command list, command handlers own command line, 

112 i permitted type, command index, 

113 number of params, parajn 1, param 2) 

114 i 

115 IENDPROC analyze command ; 

116 I 

117 analyzecommand |PROC analyze command ( TEXT CONST command list, command line, 

118 I INT CONST permitted type, 

119 I INT VAR command index, number of params, 
12© I TEXT VAR param 1, param 2) : 

121 i 

122 1 error note := ; 

123 I scan ( command line ) ; 

124 i next symbol ; 

125 I IP symbol type < > tag type AND symbol < > 

126 I THEN error ■: "Name ungueltig") ; 

127 I impossible command 

128 I ELir pos (command list, symbol) > © 

129 I THEN procedure name ; 

13® I parameter list pack option ; 

131 I nothing else in command line ; 

132 I decode command 

133 I ELSE impossible command 

134 in. 

135 I 

136 procedure name {procedure name : 

137 I procedure := sinnbol ; 

138 ! next siTnbol . 

139 I 

140 paraneterllstpackoptio | parameter list pack option : 

141 I number of params := © ; 

142 I param 1 := ; 

143 I param 2 := ; 

144 I ir symbol - "C* 

145 I THEN next s^Tnbol ; 

146 I parameter list ; 

147 j IP symbol <> AND error note » 

148 I THEN error (**) fehlt**) 

149 I PI 

150 I ELIP symbol type <> eof type 

151 I THEN error ("( fehlt") 

152 I PI . 

153 I 

154 peu*aiDeterlist | parameter list : 

155 I parameter (param 1, number of params, permitted type) ; 

156 I IP symbol = 

157 I THEN next symbol ; 

158 I parameter (param 2, number of params, permitted type) ; 

159 I PI . 

160 I 

161 nothingelseincommandli | nothing else in command line : 

162 I next symbol ; 

163 j IF symbol <> 

164 I THEN error ("Kommando zu schwierig") 

165 I PI . 

166 I 
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167 decodeccmmand | decode command : 

168 I command index := index (command list, procedure, number of paramsj 

+ I 

169 I 

170 impossiblecommand | impossible command : 

171 I command index := 0 . 

172 j 

173 lENDPROC analyze command ; 

174 I 

175 parameter |PROC parameter (TEXT VAR param, INT VAR number of params, 

176 I INT CONST permitted type) : 

177 I 

178 I IF symbol type = text type OR symbol type = permitted type 

179 I THEN param :» symbol ; 

180 I number of params I NCR 1 ; 

181 I next symbol 

132 I ELSE error ("Parameter ist kein TEXT fehlt)"; 

183 I ri 

134 I 

185 jENBPROC parameter ; 

136 I 

187 index | INT PROC index (TEXT CONST list, procedure, INT CONST params) : 

188 1 

189 I pattern : = procedure ; 

190 I pattern CAT ; 

191 I IP procedure name found 

192 I THEN get colon pos ; 

193 I get dot pos ; 

194 I get end pos ; 

195 I get command index ; 

196 I get param index ; 

197 I IF param index >= © 

198 I THEN command index ■•- param index 

199 I ELSE - command index 

200 I FI 

201 I ELSE 0 

202 I FI . 

203 I 

204 procedurencunefound | procedure name found : 

205 I lOT VAR index pos := pos (list, pattern) ; 

206 I WHILE index pos > 0 REP 

207 j IF index pos = 1 COR (list SUB index pos - 1) <= "9" 

208 ! THEN LEAVE procedure name found WITH TRUE 

209 I FI ; 

210 I Index pos := pos (list, pattern. Index pos + 1) 

211 I PER ; 

212 I FALSE . 

213 j 

214 getparamlndex |get param index : 

215 j INT CONST param index := 

216 I por (list, text (params), dot pos, end pos) - dot pos - 

I 1 . 

217 I 
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218 getconmandindex 

219 

220 

221 

222 getcolcnpos 

223 

224 

225 getdotpos 

226 

227 



228 getendpos iget end pos : 

229 I INT CONST end pos := dot pos 4 . 
23© I 

231 lENDPROC index ; 

232 I 

233 docommand | PROC do command : 

234 I 

235 I do (command handlers own command line) 

236 I 

237 lENIPRCX: do command ; 

238 I 

239 error |PROC error (TEXT CONST message) : 

24© I 

241 I error note := message ; 

242 I scan C") ; 

243 I procedure := 

244 I 

245 lENDPROC error ; 

246 I 

247 commanderror | PROC command error : 

248 I 

249 1 disable stop ; 

250 I IF error note < > 

251 I THEN srrorstop (error note) ; 

252 I error note := "** 

253 I FI ; 

254 I enable stop 

255 I 

256 lENDPROC command error ; 

257 I 

258 I 

259 nextsyrabol |PROC next symbol : 

260 I 

261 I next symbol (symbol, symbol type) 

262 I 

263 lENDPROC next symbol ; 

264 I 

265 I 
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get command index : 

INT CONST command index := 

int ( subtext (list, colon pos + 1, dot pos - 1) ) . 



get colon pos : 

INT CONST colon pos := pos (list, index pos) . 



get dot pos : 

INT CONST dot pos := pos (list, index pos) . 
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266 covertracks | PROC cover tracks : 

267 j 

268 I cover tracks (command handlers own comioand line; ; 

269 I cover tracks (previous connnand line) ; 

270 I erase buffers of compiler and do packet . 

271 I 

272 erasebuffersof compiler {erase buffers of compiler and do packet : 

273 I do (command handlers own command line) . 

274 I 

275 [ENLPROC cover tracks ; 

276 I 

277 covertracks |PROC cover tracks (TEXT VAR secret) : 

278 I 

279 I INT VAR i ; 

280 I FOR i FROM 1 UPTO LENGTH secret REP 

281 I replace (secret, i, " 

282 j PER ; 

283 i WHILE LENGTH secret < 13 REP 

284 I secret CAT " 

285 I ?ER 

286 1 

287 jENDPROC cover tracks ; 

288 I 

289 lENCPACKET command handler ; 
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1 advertising | PACKET advertising DEFINES eumel must 2uivertise : (♦ Autor: 
* I J.Liedtke ♦) 

2 I (• Stand: 08.03.85 

3 I 

4 eumelmustadvertise |PROC eumel must advertise : 

5 I 

6 I ir online AND channel <= 15 

7 I THEN out ("''i«"4'"') ; 

8 I cursor (22,5) ; 

9 I out ("E U M E 1 Version 1.8. 0/3 ''13''"10"''10"-10"") ; 

10 in. 

11 I 

12 lENIPROC eumel must advertise ; 

13 I 

14 lENDPACKET advertising ; 
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1 I 

2 taskssingle | PACKET tasks single lEPINES (* Autor: 
+ I J.Liedtke ») 

3 I (* Stand: 
I ©1.06.84 *) 

4 ! TASK , 

5 i := , 

6 ! = , 

7 I niltask , 

8 I is niltask , 

9 I myself , 

10 I archive , 

11 I father , 

12 I 

13 I dataspaces , 

14 I pcb , 

15 I status , 

16 I channel , 

17 I clock , 

18 I storage , 

19 I continue : 

20 I 

21 I 

22 I LET nil = 0 , 

23 I 

24 I hex ff = 255 , 

25 I hex 7f00 = 32512 , 

26 I 

27 I channel field = 4 , 

28 I myself no field = 9 , 

29 I myself version field = 1© , 
3© I 

31 I lowest ds number = 4 , 

32 I highest ds number = 255 , 

33 I 

34 I max channel = 32 ; 

35 I 

36 i 

37 1 

38 I TYPE TASK = STRUCT (INT no, version) ; 

39 I 

40 ITASK CONST niltask := TASK: (0.0) , 

41 I archive := TASK: (4711,4711) , 

42 I father := archive ; 

43 I 

44 myself |TASK PROC myself : 

45 I 

46 j TASK: (pcb (myself no field), pcb (myself version field)) 

47 I 

48 lENDPRCXJ myself ; 

49 I 

50 I 

51 := I OP := (TASK VAR dest, TASK CONST source) : 

52 I 

53 1 CONOR (dest) := CONOR (source) 

54 I 

55 lENDOP := ; 

56 I 
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57 = I BOOL OP = (TASK CONST left, right) : 

58 I 

59 I left.no = right.no AND left. version = right. version 

60 I 

61 lENDOP = ; 

62 I 

63 Isniltask |BOOL PROC is niltask (TASK COUST t) : 

64 I 

65 1 t.no = 0 

66 I 

67 lENDPROC is nllUsk ; 

68 I 

69 pcb I INT PROC pcb (TASK CONST id, INT CONST field) : 

70 I 

71 I EXTERNAL 104 

72 I 

73 lENDPROC pcb ; 

74 I 

75 status I INT PROC status (TASK CONST id) : 

76 I 

77 I EXTERNAL 107 

78 I 

79 lENDPROC status ; 

80 I 

81 channel |INT PROC channel (TASK CONST id) : 

82 I 

83 I pcb (id, channel field) 

84 i 

85 lENDPROC channel ; 

86 I 

87 clock IREAL PROC clock (TASK CONST id) : 

88 I 

89 I EXTERNAL 106 

90 I 

91 lENDPROC clock ; 

92 I 

93 storage |INT PROC storage (TASK CONST id) : 

94 I 

95 I INT VAR ds number, storage sura :« 0, ds size; 

96 1 FOR ds number FROM lowest ds number UPTO highest ds number REP 

97 I ds size := pages (ds number, id) ; 

98 I IF ds size >= 0 

99 I THEN storage sum INCR ((ds size + 1) DIV 2) 

100 I FI 

101 I PER ; 

102 I storage sum 

103 I 

104 lENDPROC storage ; 

105 I 



S30/2 



tasks single 



S30/2 



Zeile *HHM» ELAN EUMEL 1.8 10.11.86 *mmm» tasks single 

106 pages (INT FROC pages (INT CX)NST ds number, TASK CONST id) : 

107 I 

108 I EXTERNAL 88 

109 I 

110 lENDFE^ pages ; 

111 I 

112 continue |PROC continue (INT (X)NST channel no) : 

113 I 

114 I IF channel no > 0 AND channel no max channel 

115 I THEM write pcb (myself, channel field, channel no) 

116 I ELSE errorstop ( **ungueltlge Kanalnuauner") 

117 I FI 

118 I 

119 jlWDPRCXJ continue ; 

120 I 

121 dataspaces | INT FROC dataspaces : 

122 I 

123 I INT VAR ds number, spaces :« 0 ; 

124 I FOR ds number FROM lowest ds number UFTO highest ds number REP 

125 I IF pages (ds number, pcb (myself no field)) >= 0 

126 I THEM spaces INCR 1 

127 I FI 

128 I PER ; 

129 I spaces 

130 I 

131 lENDFROC dataspaces ; 

132 I 

133 pages |INT PROC pages (INT CONST ds number, INT CONST task no) : 

134 I EXTERNAL 88 

135 lENDPROC pages ; 

136 I 

137 writepcb |PROC write pcb (TASK CONST task, INT CONST field, value) : 

138 I EXTERNAL 105 

139 lENDPROC write pcb ; 

140 I 

141 lENDPACKETT tasks single ; 
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1 fontstore » »<hhhh>» | PACKET font store (• Autor : Rudolf 

■f I Ruland ♦) 

2 I (* Stand : 
♦ 1 18.02.86 •) 

3 I DEFINES font table, 

4 I list font tables, 
0 I list fonts, 

6 I 

7 I X step conversion, 

8 I y step conversion, 

9 I on string, 

10 j off string, 

11 I 

12 1 font, 

13 I font exists, 

14 I next larger font exists, 

15 1 next smaller font exists, 

16 I font lead, 

17 1 font height, 

18 I font depth, 

19 I indentation pitch, 

20 1 char pitch, 

21 I extended char pitch, 

22 I replacement, 

23 I extended replacement, 

24 I font string, 

25 I y offsets, 

26 I bold offset, 

27 I get font, 

26 I get replacements : 

29 I 

30 1 

31 I LET underline = 1, 

32 I bold = 2, 

33 I italics = 4, 

34 I reverse = 8, 

35 I 

36 I first font = 1, 

37 I Biax fonts = 50, 
36 I max extensions = 120, 

39 I font table type = 3009, 

40 I 

41 I PONTTABLE = STRUCT ( 

42 I 

43 I THESAURUS font names, 

44 I 

45 I TEXT replacements, font name links, 

46 I extension chars, extension indexes, 

47 I 

48 I ROW 4 TEXT on strings, off strings, 

49 I 

50 I REAL X unit, y unit, 

51 1 

52 I ROW 256 INT replacements table. 

53 I 

54 I INT last font, last extension 

55 i 

56 1 ROW max fonts STRUCT ( 

57 I TEXT font string, font name indexes, replacements, 

58 I extension chars, extension indexes, y offsets, 

59 I ROW 256 INT pitch table, replaceiwnts table, 

60 I INT Indentation pitch, font lead, font height, font 
■i- I depth, 
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61 I next larger font, next smaller font, bold offset ) 
+ 1 fonts , 

62 I 

63 I ROW max extensions STRUCT ( 

64 j TEXT replacements, 

65 I ROW 256 INT pitch table, replacements table, 

66 I INT std pitch ) 
+ I extensions , 

67 I 

68 I ) ; 

69 I 

70 jiNT VAR font nr, list index, last font, 

71 I link nr, font store replacements length; 

72 I 

73 I TEXT VAR fo table :="**, old font table, font name links, buffer; 

74 I 

75 I THESAURUS VAR font tables, font names; 

76 I 

77 jlNITFLAG VAR in this task := FALSE, 

78 I init font ds := FALSE, 

79 I init ds := FALSE; 

80 I 

81 I BOUND PONTTABLE VAR font store; 

82 I 

83 I 

84 IDATASPACE VAR font ds, ds; 

85 I 

87 I 

88 fonttable |PROC font table (TEXT (X)NST new font table) : 

89 I 

90 I disable stop; 

91 I get font table (new font table); 

92 I in this Usk ;= NOT (font table = OR type (font ds) <> font 
+ I table type); 

93 I 

94 I END PROC font table; 

95 I 

96 I 

97 getfonttable |PROC get font table (TEXT CX)NST new font table) : 

98 I 

99 I enable stop; 

100 I buffer := new font table; 

101 I change all (buffer, " **-); 

102 I IF exists (buffer) CAND type (old (buffer)) = font Uble type 

103 I THEN get font table from own task 

104 1 ELSE errorstop ( "Fonttabelle + buffer + gibt es 
+ I nicht") 

105 I FI; 

106 I 

107 I . get font table from own task ; 

108 I IF NOT initialized (init ds) THEN ds := nilspace FI; 

109 I forget (ds); ds := old (buffer); 

110 I new font store; 

111 I 

112 I . new font store : 

113 I disable stop; 

114 I IF NOT initialized (init font ds) THEN font ds :« nilspace 

I FI; 
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115 I forget ( font ds ) ; 

116 j font ds := ds; 

117 i forget (ds); 

118 I font store := font ds; 

119 I fo table := buffer; 

120 I font names := font store, font names; 

121 I font name links := font store, font name links; 

122 I last font := font store, last font; 

123 1 font store replacements length :» LENGTH font store. 
+ I replacements ; 

124 I 

125 I END PROC get font table; 

126 1 

127 I 

128 fonttable |TEXT PROC font table : 

129 I 

130 I fo table 

131 I 

132 I END PROC font table; 

133 I 

134 I 

135 listfonttables |PROC list font tables : 

136 I 

137 I enable stop; 

138 I font tables := empty thesaurus; 

139 I font tables in own task; 

140 I note font tables; 

141 I note edit; 

142 1 

143 I . font tables in own task : 

144 I list index := 0; 

145 I REP get (all, buffer, list index); 

146 I IF buffer = THEN LEAVE font tables in own task PI; 

147 I IF type (old (buffer)) = font table type 

148 I AND NOT (font tables CONTAINS buffer) 

149 I THEN insert (font tables, buffer) FI; 
15© I PER; 

151 I 

152 I . note font tables : 

153 I list index := 0; 

154 I REP get (font tables, buffer, list index); 

155 I IF buffer = 

156 I THEN LEAVE note font tables; 

157 I ELSE note (buffer); note line; 

158 I FI; 

159 I PER; 

160 I 

161 lEND PROC list font tables; 

162 I 

163 I 

164 listfonts |PROC list fonts (TEXT CONST name): 

165 I 

166 I initialize if necessary; 

167 I disable stop; 

168 I old font table := font table; 

169 I font table (name); 
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170 


1 list fonts; 


171 


1 font table ( old font table ) ; 


172 




173 


|END PROC list fonts; 


174 


1 


175 






jPnCXJ list fonts : 


177 




178 


1 enable stop; 


179 


1 initialize if necessary; 


180 


1 note font table; 


181 


1 FCX? font nr ITOM first font UPTO last font REP note font PER; 


182 


1 note edit; 


183 




184 


1 . note font table : 


loo 


1 note V iTJNTTAnMiiih ; ; note ( font table ; , 


■*■ 


1 note ( ; ;; noteline; 


186 


1 note ( X einneit = ;; note (text (font store, x unit;;; 


+ 


1 note (**;"); noteline; 


187 


1 note V y einneit s ;; note (text (font store, y unit;); 


■f 


1 note (";"); noteline; 


188 


1 


189 


1 . note font : 


190 


1 cout (font nr); 


191 


1 noteline; 


192 


1 note ( ** PWIT " ) ; note font names ; 


+ 


1 note ( ; ) ; noteline ; 


193 


1 note ( einruecKbreite = ); note (text(ront. 




j indentation pitch)); note (**;**); noteline; 


194 


1 note ( durcnscnuss = ;, note (text(ront. font 




1 leaa;;, noxe ^ « /« no be line, 


1 OR 


1 noxe V lontnoene = ;, noxe vxexxvionx. lonx 


+ 


1 neignt)); note ( ; ); noteline; 


196 


1 note ( fonttiefe = ); note (text(font. font 


+ 


1 depth)); note (";**); noteline; 


197 


1 note (** groesserer font = *""*); note (next larger); 




j note ( ; ); noteline; 


198 


1 note (** kleinerer font = ♦»»»»» j. ^ote (next smaller); 


+ 


1 note (""";*'); noteline; 


199 


1 


200 


1 . font : font store, fonts (font nr) 


201 


1 . next larger : name (font store, font names, font, next larger 


+ 


1 font ) 


202 


1 . next smaller : name (font store, font names, font, next 


+ 


1 smaller font) 


203 


1 


204 


1 . note font names : 


205 


1 INT VAR index; 


206 


1 note ( ) ; 


207 


j note (name (font names, font, font name indexes ISUB 1)); 


208 


1 note ( ) ; 


209 


1 FOR index jnOM 2 uFTO LrlvGTH font, font name indexes SIV 2 


210 


1 KiSr note ( , ; , 


211 


1 note (name (font names, font, font name indexes ISUB 


+ 


1 index) ) ; 


212 


1 noxe I ; , 


213 


I PER; 


214 




215 


I END PROC list fonts; 


216 
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217 i 

218 xstepconversicr. | INT PROC x step conversion (REAL CONST cm) : 

219 i 

22© I initialize if necessary; 

221 I IF cm >= 0.0 

222 I THEN int (cm * font store. >: unit + 0.5 ) 

223 I ELSE int (cm » font store, x unit - 0.5 ) 

224 I ri 

225 I 

226 I END PROC x step conversion; 

227 I 

228 ! 

229 xstepconversion |REAL PROC x step conversion (INT CONST steps) : 

230 I 

231 I initialize if necessary; 

232 I real ^ steps) / font store, x unit 

233 I 

234 I END PROC x step conversion; 

235 I 

236 1 

237 ystepconversion | INT PROC y step conversion (REAL CONST cm) : 

238 I 

239 I initialize if necessary; 

240 I IF cm >= 0.0 

241 1 THEN int (cm • font store, y unit + 0.5 ) 

242 j ELSE int (cm » font store, y unit - 0.5 ) 

243 I FI 

244 I 

245 I END PROC y step conversion; 

246 I 

247 I 

248 ystepconversion |REAL PROC y step conversion (INT CONST steps) : 

249 I 

250 1 initialize if necessary; 

251 I real (steps) / font store, y unit 

252 I 

253 I END PROC y step conversion; 

254 j 

255 I 

256 onstring |TEXT PROC on string (INT CONST modification) : 

257 I 

258 I initialize if necessary; 

259 I SELECT modification OF 

260 I CASE underline : font store, on strings (1) 

261 1 CASE bold : font store, on strings (2) 

262 I CASE italics : font store, on strings (3) 

263 I CASE reverse ; font store, on strings (4) 

264 j OTHERWISE : errorstop ( "unzulaessige Modif ikation" ) ; 

265 I END SELECT 

266 j 

267 I END PROC on string; 

268 I 
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269 



270 
271 
272 
273 
274 
275 
276 
277 
278 
279 
280 
281 
282 
283 



284 
285 
286 
287 
288 
289 
290 
291 
292 
293 
294 
295 
296 
297 



298 
299 
300 
301 
302 
303 
304 
305 
306 
307 
308 
309 
310 



311 
312 
313 
314 
315 
316 
317 



offstring 



font 



font 



fontexists 



318 nextlargerfontexists 

319 

320 



TEXT PROC off string (INT CONST modification) : 

initialize if necessary; 

SELECT modification OF 

CASE underline : font store, off strings (1) 
CASE Y-ld : font store, off strings (2) 

CASE italics : font store, off strings (3) 
CASE reverse : font store, off strings (4) 

OTHEEWISE : errorstop ( "unzulaessige Modif ikation" ) ; 

END SELECT 

END PROC off string; 



INT PROC font (TEXT CONST font name) : 

initialize if necessary; 

buffer := font name; 

change all (buffer, " ""); 

INT CONST link nr := link (font names, buffer) 

IF link nr <> 0 

THEN font name links ISUB link nr 

ELSE 0 

FI 

END PROC font; 



TEXT PROC font (INT CONST font number) : 
initialize if necessary; 

IF font number >= first font AND font number <= last font 
THEN name (font names, fonts, font name indexes ISUB 1) 
ELSE 

FI 

. fonts : font store, fonts (font number) 
END PROC font; 



BOOL PROC font exists (TEXT CONST font name) : 

font (font name) <> 0 
END PROC font exists; 



BOOL PROC next larger font exists (INT CONST font number, 

INT VAR next larger font) 
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321 I initialize if necessary; 

322 I ir font number >= first font AND font number <= last font 

323 I THEN next larger font := fonts, next larger font; 

324 I IF next larger font <> 0 

325 I THEN next leurger font ;= font name links ISUB next 
+ I larger font; 

326 I next larger font <> 0 

327 I ELSE FALSE 

328 I FI 

329 I ELSE errors top ("Font " + text (font number) + " gibt es 
+ I nicht**); 

330 I FALSE 

331 I FI 

332 I 

333 I . fonts : font store, fonts (font number) 

334 I 

335 I END PROC next larger font exists; 

336 I 

337 I 

338 nextsmallerfontexists |BOOL PROC next smaller font exists (INT CONST font number, 

339 I INT VAR next smaller font) : 

340 I 

341 I initialize if necessary; 

342 I IF font number >= first font AND font number <= last font 

343 I THEN next smaller font := fonts, next smaller font; 

344 I IF next smaller font <> 0 

345 I THEN next smaller font := font name links ISUB next 
+ I smaller font; 

346 I next smaller font <> 0 

347 I ELSE FALSE 

348 I FI 

349 I ELSE errorstop ("Font " + text (font number) + " gibt es 
+ I nicht"); 

350 I FALSE 

351 I FI 

352 I 

353 I . fonts : font store, fonts (font number) 

354 I 

355 I END PROC next smaller font exists; 

356 I 

357 I 

358 fontlead |INT PROC font lead (INT CONST font number) : 

359 I 

360 I initialize if necessary; 

361 I IF font number >= first font AND font number <= last font 

362 I THEN fonts, font lead 

363 I ELSE errorstop ("Font " + text (font number) + " gibt es 
+ I nicht"); 0 

364 I FI 

365 I 

366 I . fonts : font store, fonts (font number) 

367 I 

368 I END PROC font lead; 

369 I 

370 I 
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371 fontheight |INT PROC font height (INT CONST font number) : 

372 I 

373 I initialize if necessary; 

374 I IF font number >= first font AND font number <= last font 

375 I THEN fonts, font height 

376 I ELSE errorstop ("Font " + text (font number) + " gibt es 
+ i nichf); 0 

377 I FI 

378 I 

379 I . fonts : font store, fonts (font number) 

380 I 

381 I END PROC font height; 

382 I 

383 I 

384 fontdepth |INT PROC font depth (INT CONST font number) : 

385 I 

386 ! initialize if necessary; 

387 I IF font number >= first font AND font number <= last font 

388 I THEN fonts, font depth 

389 I ELSE errorstop ("Font " -»■ text (font number) + ** gibt es 
+ j nicht"); 0 

390 I FI 

391 I 

392 I . fonts : font store, fonts (font number) 

393 I 

394 I END PROC font depth; 

395 I 

396 I 

397 indentationpitch |INT PRCXJ indentation pitch (INT CONST font number) : 

398 I 

399 I initialize if necessary; 

400 I IF font number >= first font AND font number <= last font 

401 I THEN fonts, indentation pitch 

402 I ELSE errorstop ("Font " + text (font number) + " gibt es 
+ I nichf); 0 

403 I' FI 

404 I 

405 I . fonts : font store, fonts (font number) 

406 I 

407 I END PRCXJ indentation pitch; 

408 i 

409 I 

410 charpitch |INT PRCW char pitch (INT CONST font number, 

411 I TEXT CONST char ) : 

412 I 

413 I initialize if necessary; 

414 I IF font number >= first font AND font number <= last font 

415 I THEN INT CONST pitch := font, pitch table (code (char SUB 1) 

I 1); 

416 I IF pitch = maxint 

417 I THEN extended char pitch (font number, char SUB 1, 
+ I char SUB 2) 

418 I ELIF pitch < 0 

419 I THEN pitch XOR (-maxint-1) 

420 I ELSE pitch 

421 I FI 
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422 

423 
424 
425 
426 
427 
428 
429 



43© extendedcharpitch 
431 
432 
433 
434 
435 
436 
+ 

437 
438 
439 
440 
441 
442 
443 
444 
445 
446 
+ 

447 
448 
449 
450 
451 



452 replacement 
453 
454 
455 
456 
457 
+ 

458 
459 
+ 

460 
461 
462 

463 
464 
465 
466 
467 
466 
469 
470 
471 
472 
473 



ELSE errorstop ("lonx " + text (font number) + " gibt es 
nicht"); © 

ri 

. font : font store, fonts (font number) 

END PROC char pitch; 



I INT PROC extended chax pitch (INT CONST font number, 

I TEXT CONST esc char, char) : 

I initialize if necessary; 

I IP font number >= first font AND font number <= last font 
I THEN extension, pitch table (code ^char) + 1) 
I ELSE errorstop ("Pont ** + text (font number) + " gibt es 
I nicht"); 0 

I n 

I . font : font store, fonts (font number) 

I . extension : font store, extensions (extension number) 

. extension number : 

INT CONST index := pes (font, extension chars, esc char); 
IF index = 0 

THEN errorstop * esc char + char + hat keine 

Erweiterung" ) PI; 
font, extension indexes ISUB index 

END PROC extended char pitch; 



TEXT PROC replacement (INT CONST font number, 
TEXT CONST char ) : 

initialize if necessary; 

IP font number >« first font AND font number <« last font 

THEN link nr := font, replacements table (code (char SUB 1) -f 

1); 

IP link nr = maxint 

THQf extended replacement (font number, char SUB 1, 

char SUB 2) 
ELSE process font replacement 

PI 

ELSE errorstop ("Font ** + text (font number) " gibt es 
nicht"); 



. font : font store, fonts (font number) 

. process font replacement : 

IP link nr < 0 THEN link nr := link nr XOR (-maxlnt-1) FI; 
IF link nr = 0 
THEN char 

BLIP link nr > font store replacements length 

THEN link nr DECR font store replacements length; 
replacement text (font, replacements) 
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474 
475 
476 
477 
478 
479 



480 extendedreplacement 
481 
482 
483 
484 
485 
486 
+ 

487 
488 
489 
490 
491 
492 
493 
494 

495 
496 
497 
498 
499 
500 
+ 

501 

502 
503 
-t- 

504 
505 
•♦- 

506 
+ 

507 
508 
509 
+ 

510 
511 

512 
513 
514 
515 

■I- 

516 
517 
+ 

518 
519 
520 
521 
522 



ELSE replacement text (font store, replacements) 

ri 

ENE FROC replacement; 



TEXT PROC extended replacement (INT CONST font number, 

TEXT CONST esc char, char ) : 

initialize if -necessary; 

ir font number >= first font AND font number <= last font 
THEN process extension replacement 

ELSE errors top ("Pont " + text (font number) + " gibt es 
nicht**); 

ri 

. process extension replacement : 
determine extension link nr; 
ir link nr = 0 
THEll char 

ELir link nr > font store extension replacements length 
THEN link nr DECR font store extension replacements 
length; 

replacement text (font extension, replacements) 
ELSE replacement text (font store extension, replacements) 

ri 

. determine extension link nr : 

INT CONST index 1 := pes (font, extension chars, esc 
char) ; 

INT CONST index 2 := pes (font store, extension chars, esc 

char ) ; 
IF index 1 <> 0 

THEN link nr := font extension, replacements table 
(code (char) + 1) ; 
ELIF index 2 <> 0 

THEN link nr := font store extension, replacements 

table (code (char) + 1); 
ELSE errorstop ( + esc char + char + hat 
keine Erweiterung** ) 

FI; 

. font extension : font store, extensions (font 

extension number) 

. font extension number : font, extension indexes ISUB 

index 1 

. font : font store, fonts (font number) 

. font store extension : font store, extensions (font 

store extension number) 

. font store extension number : font store, extension indexes 
ISUB index 2 

. font store extension replacements length : 
IF index 2=0 
THEN 0 

ELSE LENGTH font store extension, replacements 
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523 I ri 

524 I 

525 I END PROC extended replacement; 

526 I 

527 I 

528 replacementtext jTEXT PROC replacement text (TEXT CONST replacements) : 

529 I 

530 I buffer := subtext (replacements, link nr + 1, 

531 I link nr -t- code (replacements SUB 
+ I link nr)); 

532 I buffer 

533 I 

534 I END PROC replacement text; 

535 I 

536 I 

537 fontstring |TEXT PROC font string (INT CONST font number) : 

538 I 

539 I initialize if necessary; 

540 I IF font number >= first font AND font number <= last font 

541 I THEN fonts, font string 

542 I ELSE errorstop ("Font ** + text (font number) + " gibt es 
+ I nicht"); 

543 j FI 

544 I 

545 I . fonts : font store, fonts (font number) 

546 I 

547 I END PROC font string; 

548 I 

549 1 

550 yoffsets |TEXT PROC y offsets (INT CONST font number) : 

551 I 

552 I initialize if necessary; 

553 I IF font number >= first font AND font number <= last font 

554 I THEN fonts, y offsets 

555 I ELSE errorstop ("Font " + text (font number) + " gibt es 
+ I nicht"); "" 

556 I FI 

557 I 

558 I . fonts : font store, fonts (font number) 

559 I 

560 I END mOC y offsets; 

561 I 

562 I 

563 boldoffset [INT PROC bold offset (INT CONST font number) : 

564 I 

565 I initialize if necessary; 

566 I IF font number >= first font AND font number <= last font 

567 I THEN fonts, bold offset 

568 1 ELSE errorstop ("Font " + text (font number) + " gibt es 
+ I nicht"); 0 

569 I FI 

570 I 

571 I . fonts : font store, fonts (font number) 

572 I 
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573 I END PROC bold offset; 

574 I 

575 I 

576 getfont |PROC get font (INT CONST font number, 

577 I INT VAR indentation pitch, font lead, font height, 
■»- I font depth, 

578 I ROW 256 INT VAR pitch table ) : 

579 I 

580 I Initialize if necessary; 

581 I IF font number >= first font AND font number <= last font 

582 1 THEN indentation pitch := fonts, indentation pitch; 

583 I pitch table := fonts, pitch table; 

584 I font lead := fonts, font lead; 

585 I font height := fonts, font height; 

586 I font depth := fonts, font depth; 

587 I ELSE errorstop (''Pont " + text (font number) + gibt es 
+ I nichf); 

588 I FI; 

589 I 

590 I . fonts : font store, fonts (font number) 

591 I 

592 I END PROC get font; 

593 j 

594 I 

595 getreplacements |PROC get replacements (INT CONST font number, 

596 I TEXT VAR replacements, 

597 I ROW 256 INT VAR replacements table) : 

598 I 

599 I initialize if necessary; 

60© I IP font number >= first font AND font number <= last font 

601 I THEN replacements := font store, replacements; 

602 I replacements CAT fonts, replacements; 

603 I replacements table := fonts, replacements table; 

604 I ELSE errorstop ("Font " + text (font number) + ** gibt es 
+ 1 nichf); 

605 I FI; 

606 I 

607 I . fonts : font store, fonts (font number) 

608 I 

609 I END PROC get replacements; 

610 I 

611 I 

612 initializeif necessary |PROC initialize if necessary : 

613 I 

614 I IF NOT initialized (in this task) 

615 I THEN IF font table » 

616 I THEN in this task := FALSE; 

617 I errorstop ( "Font tabe lie noch nicht eingestellt") ; 

618 I ELSE font table (font table); 

619 I FI; 

620 I FI; 

621 I 

622 I END PROC initialize if necessary; 

623 I 

624 I 

625 I END PACKET font store; 
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1 !(• VERSION 3 17.03.86 •) 

2 nameset <mhm»»«*mhhhhm»»«»«« | PACKET name set DEFINES (♦ Autor: J.Liedtke ♦) 

3 I 

4 I ALL , 

5 I SOME , 

6 I LIKE , 

7 I + . 

8 I - . 

9 I / , 

10 j do , 

11 I FILLBY , 

12 I remainder , 

13 I 

14 I fetch , 

15 I save , 

16 I fetch all , 

17 I save all , 

18 I forget , 

19 I erase , 

20 I insert » 

21 I edit : 

22 I 

23 I 

24 I LET cr If = ""is""!©"" ; 

25 I 

26 (TEXT VAR name ; 

27 IDATASPACE VAR edit space ; 

28 1 

29 I THESAURUS VAR remaining thesaurus empty thesaurus ; 

30 I 

31 I 

32 ♦ I THESAURUS OP + (THESAURUS CONST left, right) : 

33 I 

34 I THESAURUS VAR union := left ; 

35 1 INT VAR index := 0 ; 

36 I get (right, name, index) ; 

37 I WHILE name <> **" REP 

38 I IF NOT (union CONTAINS name) 

39 I THEN insert (union, name) 

40 i FI ; 

41 1 get (right, name, index) 

42 I PER ; 

43 I union . 

44 I 

45 lENDOP * ; 

46 1 

47 + I THESAURUS OP + (THESAURUS CONST left, TEXT CONST right) : 

48 I 

49 I THESAURUS VAR union := left ; 

50 1 IF NOT (union CONTAINS right) 

51 1 THEN insert (union, right) 

52 I FI ; 

53 I union . 

54 I 

55 lENDOP + ; 

56 I 
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57 - I THESAURUS OP - (THESAURUS CONST left, right) : 

58 I 

59 I THESAURUS VAR difference := empty thesaurus ; 

60 I INT VAR index := 0 ; 

61 I get (left, name, index) ; 

62 I WHILE name <> REP 

63 I IF NOT (right CONTAINS name) 

64 I THEN insert (difference, name) 

65 I ri ; 

66 I get (left, name, index) 

67 I PER ; 

68 I difference . 

69 I 

70 lENDOP - ; 

71 I 

72 - I THESAURUS OP - (THESAURUS CONST left, TEXT CONST right) : 

73 I 

74 1 THESAURUS VAR difference := left ; 

75 I INT VAR index ; 

76 I delete (difference, right, index) ; 

77 I difference . 

78 j 

79 lENDOP - ; 

80 I 

81 / I THESAURUS OP / (THESAURUS CONST left, right) : 

82 I 

83 I THESAURUS VAR intersection := empty thesaurus ; 

84 I INT VAR index := 0 ; 

85 I get (left, name, index) ; 

86 I WHILE name <> ''"REP 

87 j IF right CONTAINS name 

88 I THEN insert (intersection, name) 

89 I FI ; 

90 I get (left, name, index) 

91 I PER ; 

92 I intersection . 

93 I 

94 |ENIX)P / ; 

95 I 

96 ALL [THESAURUS OP ALL (TEXT CONST file name) : 

97 I 

98 I FILE VAR file := sequential file (input, file name) ; 

99 I THESAURUS VAR thesaurus := empty thesaurus ; 

100 I thesaurus FILLBY file ; 

101 I thesaurus . 

102 I 

103 lENDOP ALL ; 

104 I 

105 SOME I THESAURUS OP SOME (THESAURUS CONST thesaurus) : 

106 I 

107 I copy thesaurus into file ; 

108 I edit file ; 

109 I copy file into thesaurus . 

110 I 
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111 copythesaurusintofile |copy thesaurus into file : 

112 I forget (edit space) ; 

113 I edit space := nilspace ; 

114 I FILE VAR file := sequential file (output, edit space) ; 

115 I file FILLBY thesaurus . 

116 I 

117 editfile |edit file : 

118 I modify (file) ; 

119 I edit (file) . 

120 I 

121 copyfileintothesaurus |copy file into thesaurus : 

122 I THESAURUS VAR result := empty thesaurus ; 

123 I input (file) ; 

124 I result FILLBY file ; 

125 I forget (edit space) ; 

126 I result . 

127 I 

128 lENDOP SOME ; 

129 I 

130 SOME [THESAURUS OP SOME (TASK CONST task) : 

131 I 

132 I SOME ALL task 

133 I 

134 lENDOP SOME ; 

135 I 

136 SOME I THESAURUS OP SOME (TEXT CONST file name) : 

137 1 

138 I SOME ALL file name 

139 1 

140 lENDOP SOME ; 

141 I 

142 LIKE I THESAURUS OP LIKE (THESAURUS CONST thesaurus, TEXT CONST pattern) : 

143 I 

144 I THESAURUS VAR result: = empty thesaurus ; 

145 I INT VAR index := 0 ; 

146 I REP get (thesaurus, name, index) ; 

147 I IF name = 

148 I THEN LEAVE LIKE WITH result 

149 I ELIF name LIKE pattern 

150 I THEN insert (result, name) 

151 I FI 

152 I PER ; 

153 I result . 

154 I 

155 lENDOP LIKE ; 

156 I 

157 remainder | THESAURUS PROC remainder : 

158 I 

159 I remaining thesaurus 

160 I 

161 lENDPROC remainder ; 

162 I 
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163 do IPRCX; do (PROC (TEXT CONST) operate » THESAURUS CONST thesaurus) : 

164 I 

165 I INT VAR index := 0 , operation number 0 ; 
ie36 I TEXT VAR name ; 

167 I 

168 I remaining thesaurus := empty thesaurus ; 

169 I disable stop ; 

170 I work off thesaurus ; 

171 I fill leftover with remainder . 

172 I 

173 workoff thesaurus |work off thesaurus : 

174 I REP 

175 I get (thesaurus, name, index) ; 

176 I IF name = 

177 I THEN LEAVE work off thesaurus 

178 I ri ; 

179 I operation number INCR 1 ; 

180 I cout (operation number) ; 

181 I execute (PROC (TEXT CONST) operate, name) 

182 I UNTIL is error ENDREP . 

183 I 

184 f illleftoverwithremain |fill leftover with remainder : 

185 I WHILE name <> ""REP 

186 I insert (remaining thesaurus, name) ; 

187 I get (thesaurus, name, index) 

188 I PER . 

189 I 

190 lENDPROC do ; 

191 I 

192 execute |PR(DC execute (PROC (TEXT CONST) operate, TEXT CONST name) : 

193 I 

194 I enable stop ; 

195 I operate (name) 

196 I 

197 lENDPROC execute ; 

198 I 

199 do I PROC do (PROC (TEXT CONST, TASK CONST) operate, THESAURUS CONST 

+ I thesaurus, 

200 1 TASK CONST task) : 

201 I 

202 I INT VAR index := 0 , operation number := 0 ; 

203 I TEXT VAR name ; 

204 I 

205 1 remaining thesaurus := empty thesaurus ; 

206 I disable stop ; 

207 I work off thesaurus ; 

208 I fill leftover with remainder . 

209 I 

210 workoff thesaurus |work off thesaurus : 

211 I REP 

212 I get (thesaurus, name, index) ; 

213 I IF name = *"* 

214 I THEN LEAVE work off thesaurus 

215 I FI ; 

216 I operation number INCR 1 ; 
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217 I cout (operation number) ; 

218 I execute (PROC (TEXT CONST, TASK CONST) operate, name, task) 

219 I UNTIL is error ENDREP . 

220 j 

221 fillleftoverwithremain |fill leftover with remainder : 

222 I WHILE name <> REP 

223 I insert (remaining thesaurus, name) ; 

224 I get (thesaurus, name, index) 

225 I PER . 

226 I 

227 lENDPROC do ; 

228 I 

229 execute |PROC execute (PROC (TEXT CONST, TASK CONST) operate. 

230 I TEXT CONST name, TASK CONST task) : 

231 I 

232 I enable stop ; 

233 I operate (name, task) 

234 I 

235 lENDPROC execute ; 

236 I 

237 FILLBY |0P FILLBY (THESAURUS VAR thesaurus, FILE VAR file) : 

238 I 

239 I WHILE NOT eof (file) REP 

240 I getline (file, name) ; 

241 I delete trailing blanks ; 

242 I IF name <> CAND NOT (thesaurus CONTAINS name) 

243 I THEN insert (thesaurus, name) 

244 I FI 

245 I PER . 

246 I 

247 deletetrailingblanks | delete trailing blanks : 

248 I WHILE (name SUB LENGTH name) = " " REP 

249 I name := subtext (name, 1, LENGTH nsune - 1) 

250 I PER . 

251 I 

252 lENDOP FILLBY ; 

253 I 

254 FILLBY |0P FILLBY (FILE VAR file, THESAURUS CONST thesaurus) : 

255 I 

256 I INT VAR index := 0 ; 

257 I REP 

258 I get (thesaurus, name, index) ; 

259 I IF name = "** 

260 I THEN LEAVE FILLBY 

261 I FI ; 

262 I put line (file, name) 

263 I PER . 

264 I 

265 lENDOP FILLBY ; 

266 I 
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267 FILLBY |0P FILLBY (TEXT CX)NST file name, THESAURUS CONST thesaurus) : 

268 I 

269 I FILE VAR f := sequential file (output, file name) ; 

270 I f FILLBY thesaurus 

271 1 

272 lENDOP FILLBY ; 

273 I 

274 I 

275 I 

276 fetch |PROC fetch (THESAURUS CONST nameset) : 

277 I 

278 I do (PROC (TEXT CONST) fetch, nameset) 

279 I 

280 lENDPROC fetch ; 
2S1 I 

282 fetch |PROC fetch (THESAURUS CONST nameset, TASK CONST task) : 

283 I 

284 I do (PROC (TEXT CONST, TASK CONST) fetch, nameset, task) 

285 I 

286 lENDPROC fetch ; 

287 I 

288 save |PROC save (THESAURUS CONST nameset) : 

289 I 

290 I do (PROC (TEXT CONST) save, nameset) 

291 I 

292 lENDPROC save ; 

293 I 

294 save |PROC save (THESAURUS CONST nameset, TASK CONST task) : 

295 I 

296 I do (PROC (TEXT CONST, TASK CONST) save, nameset, task) 

297 I 

298 lENDPROC save ; 

299 I 

300 fetchall |PROC fetch all : 

301 I 

302 I fetch all (father) 

303 I 

304 lENDPROC fetch all ; 

305 I 

306 fetchall |PROC fetch all (TASK CONST manager) : 

307 I 

308 I fetch (ALL mansiger, manager) 

309 I 

310 lENDPROC fetch all ; 

311 I 

312 saveall | PROC save all : 

313 I 

314 I save all (father) 
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315 I 

316 lENDPROC save all ; 

317 I 

318 saveall jPROC save all (TASK CONST manager) : 

319 1 

320 I save (ALL myself, manager) 

321 I 

322 lENDPROC save all ; 

323 I 

324 forget |PROC forget (THESAURUS CONST nameset) : 

325 I 

326 I do (PROC (TEXT CONST) forget, nameset) 

327 I 

328 lENDPROC forget ; 

329 I 

330 erase |PROC erase (THESAURUS CONST nameset) : 

331 I 

332 I do (PROC (TEXT CONST) erase, nameset) 

333 I 

334 lENDPROC erase ; 

335 I 

336 erase |PROC erase (THESAURUS CONST nameset, TASK CONST task) : 

337 I 

338 I do (PROC (TEXT CONST, TASK CONST) erase, nameset, task) 

339 I 

340 lENDPROC erase ; 

341 I 

342 insert |PROC insert (THESAURUS CONST nameset) : 

343 I 

344 I do (PROC (TEXT CONST) insert, nameset) 

345 I 

346 lENDPROC insert ; 

347 I 

348 edit |PROC edit (THESAURUS CONST nameset) : 

349 I 

350 I do (PROC (TEXT CONST) edit, nameset) 

351 I 

352 lENDPROC edit ; 

353 I 

354 lENDPACKET name set ; 
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1 I 

2 systeminfo •»*»♦♦»»»••*••» | PACKET system info DEFINES (» Autor: J.Liedti^ 
+ I •) 

3 I (* Stand: 22.09.84 

I •) 

4 I task status , 

5 I storage info , 

6 I help : 

7 I 

8 I 

9 I LET channel field = 4 » 

10 I prio field = 6 , 

11 I 

12 I cr If = «»»i3"ni0»'*» ^ 

13 I cr = ""13"" , 

14 I page = •"»i''-4'"' , 

15 I begin raark= ""is*'*' , 

16 I end mark = "♦'14"" , 

17 I bell = ""7"" , 

18 I esc = ""27"" ; 

19 I 

20 I 

21 I 

22 cputimeof |TEXT PROC cpu time of (TASK CONST actual task) : 

23 I 

24 I disable stop ; 

25 I TEXT VAR result := subtext (time (clock (actual task), 12), 1, 10) 
+ I i 

26 I IF is error 

27 I THEN clear error ; 

28 I result := 10 • "•" 

29 I FI ; 

30 I result 

31 I 

32 lENDPRCX: cpu time of ; 

33 I 

34 taskstatus |PROC task status : 

35 i 

36 I line ; 

37 I put (date); put (time of day) ; 

38 I line (2) ; 

39 I put ("Speicher:") ; put (storage (myself)); putline ("K"); 

40 I put ("CPU-Zeit:") ; put (cpu time of (myself)) ; line; 

41 I line . 

42 I 

43 lENDPROC task status ; 

44 I 

45 storageinfo |PROC storage info : 

46 I 

47 I INT VAR size, used ; 

48 I storage (size, used) ; 

49 I out (""13""10" ") ; 

50 I put (used) ; 

51 I put ("K von") ; 

52 I put (size plus reserve) ; 

53 I putline ( "K sind belegt?") . 
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54 I 

55 sizeplusreserve |size plus reserve : 

56 I int (real (size + 24) • 64.0 / 63.0 ) . 

57 I 

58 lENLPROC storage info ; 

59 I 

60 I 

61 help IPROC help : 

62 I 

63 I IF exists (''help") 

64 I THEN FILE VAR f := sequential file (modify, ''help") ; 

65 I help (f) 

66 I ELSE errorstop ( "^•"help''*' gibt es nicht") 

67 I FI . 

68 I 

69 lENDPROC help ; 

70 I 

71 help IPROC help (FILE VAR help file) : 

72 I 

73 j initialize help command ; 

74 I REP 

75 1 out (page) ; 

76 I to paragraph ; 

77 I show paragraph ; 

78 I get show command 

79 I UNTIL is quit command PER . 

80 I 

81 initial izehelpcommand [initialize help command : 

82 I TEXT VAR 

83 I help command := getcharety ; 

84 I IF help command = 

85 I THEN help command := "0" 

86 I FI . 

87 I 

88 toparagraph |to paragraph : 

89 I col (help file, 1) ; 

90 1 to line (help file, 1) ; 

91 I downety (help file, + help command + "#**) ; 

92 i IF eof (help file) 

93 I THEN to line (help file, 1) ; 

94 I out (bell) 

95 I FI . 

96 I 

97 showparagraph jshow paragraph : 

98 I show headline ; 

99 I WHILE NOT end of help subfile REP 

100 I show help line 

101 I PER ; 

102 I show bottom line . 

103 I 

104 showheadline jshow headline : 

105 I out (begin mark) ; 

106 i INT CONST dots := (x size - len (help file) - 5) DIV 2 ; 
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107 I dots TIMESOUT ; 

108 I exec (PROC show line, help file, 4) ; 

109 I dots TIMESOUT ; 

110 I out (end mark) ; 

111 I down (help file) . 

112 I 

113 showhelpline jshow help line : 

114 I out (or If) ; 

115 I exec (PROC show line, help file, 1) ; 

116 I down (help file) . 

117 I 

118 showbottomline jshow bottom line : 

119 I cursor (5, y size) ; 

120 I exec (PROC show line, help file, 3) ; 

121 I out (cr) . 

122 I 

123 getshowcommand |get show command : 

124 I TEXT VAR char ; 

125 I get char (char) ; 

126 I IF char = esc 

127 I THEN get char (char) 

128 I PI ; 

129 I IF char >«*''* 

130 I THEN help command := char 

131 I ELSE out (bell) 

132 I FI . 

133 1 

134 endofhelpsubfile jend of help subfile : pos (help file, "##**, 1) <> 0 OR eof (help file) 
+ 

135 I 

136 isquitcommand |is quit command : help command = "q** OR help command = **Q** . 

137 I 

138 lENDPROC help ; 

139 I 

140 showline |PROC show line (TEXT CONST line, INT CONST from) : 

141 I 

142 I outsubtext (line, from, x size - from) 

143 I 

144 lENDPROC show line ; 

145 I 

146 lENDPACKET system info ; 
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1 |(, VERSION 2 26.05.86 •) 

2 singleusermonitor •**»»••» | PACKET single user monitor DEFINES (« Autor: J.Liedtke ♦) 

3 I 

4 I monitor , 

5 I shutup , 

6 I save system , 

7 I fixpoint , 

8 j collect g€urbage blocks , 

9 I set clock , 

10 I set date : 

11 I 

12 1 

13 I LET command list = 

14 I 

15 I "edit : 1 . ©Irun : 3. 01runagain : 5 . ©insert : 6 . 01f orget : 8 . ©Irename : 10 . 2copy : 1 
+ I 1.2 

16 list I li s t : 12 . ©storageinf o : 13 . ©fetch : 14 . Isave : 15 . ©Isaveall : 17 . ©shutup: 18 . 0 

17 help I help: 19.© " ; 

18 I 

19 ILET text param type = 4 , 

20 I main channel = 1 , 

21 I cr = ''•♦13'"' ^ 

22 I 

23 I garbage collect code = 1 , 

24 I fixpoint code = 2 , 

25 I shutup code = 4 , 

26 I shutup and save code = 12 ; 

27 I 

28 I 

29 jiNT VAR command index , number of params , previous heap size , 

30 I old session := session ; 

31 (TEXT VAR param 1, param 2 , date text; 

32 I 

33 I 

34 monitor | PROC monitor : 

35 I 

36 I monitor (PROC set up) 

37 I 

38 lENDPROC monitor ; 

39 I 

40 monitor |PROC monitor (PROC init system) : 

41 I 

42 I disable stop ; 

43 I previous heap size := heap size ; 

44 I REP 

45 I continue (main channel) ; 

46 1 command dialogue (TRUE) ; 

47 I sysin (**") ; 

48 I sysout (**") ; 

49 I reset editor ; 

50 j init system if necessary ; 

51 I cry if not enough storage ; 

52 I get command ("gib kommando :**) ; 

53 I analyze command (command list, text param type, 

54 I command index, number of params, pararal, 
-t- I par€un2) ; 
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55 I execute command ; 

56 I collect heap garbage if necessary 

57 I PER . 

58 I 

59 collectheapgaurbageifne j collect heap garbage if necessary : 

60 I IF heap size > previous heap size + 6 

61 I THEN collect heap garbage ; 

62 I previous heap size := heap size 

63 I FX . 

64 I 

65 initsystemifnecessary |init system if necessary : 

66 I IF session <> old session 

67 I THEN old session := session ; 

68 I continue (main channel) ; 

69 I clear error ; 

70 I init system ; 

71 I eumel must advertise ; 

72 I set date ; 

73 I storage info 

74 I FI . 

75 I 

76 cryifnotenoughstorage |cry if not enough storage : 

77 I INT VAR size, used ; 

78 I storage (size, used) ; 

79 I IF used > size 

80 I THEN out ( "''7''Speicher Engpass! Dateien loeschen!'*13"*'10**") 

81 I FI . 

82 I 

83 reseteditor | reset editor : 

84 I WHILE aktueller editor > 0 REP 

85 I quit 

86 I PER . 

87 I 

88 lENDPROC monitor ; 

89 I 

90 executecommand |PR(X1 execute command : 

91 I 

92 I enable stop ; 

93 1 SELECrr command index OF 

94 I CASE 1 : edit 

95 I CASE 2 : edit (paraml) 

96 I CASE 3 : run 

97 I CASE 4 : run (paraml) 

98 I CASE 5 : run again 

99 I CASE 6 : insert 

100 I CASE 7 : insert (paraml) 

101 I CASE 8 : forget 

102 I CASE 9 : forget (paraml) 

103 I CASE 10: rename (pareiml, param2) 

104 I CASE 11: copy (paraml, param2) 

105 1 CASE 12: list 

106 I CASE 13: storage info 

107 I CASE 14: fetch (paraml) 

108 I CASE 15: save 

109 I CASE 16: save (paraml) 

110 I CASE 17: save all 
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111 I CASE 18: shutup 

112 I CASE 19: help 

113 I OTHERWISE do command 

114 I ENDSELECT . 

115 1 

116 lENDPROC execute command ; 

117 I 

118 I BOOL VAR hardware clock ok ; 

119 I REAL VAR now ; 

120 1 

121 setdate |PROC set date : 

122 1 

123 I hardware clock ok := TRUE ; 

124 I try to get date and time from hardware ; 

125 I IF NOT hardware clock ok 

126 I THEN get date and time from user 

127 I ri ; 

128 I define date and time . 

129 I 

130 trytogetdateandtimefro |try to get date and time from hetrdware : 

131 I disable stop ; 

132 I REAL VAR previous now ; 

133 I now := 0.0 ; 

134 I INT VAR try ; 

135 I rOR try FROM 1 UPTO 3 WHILE hardware clock ok REP 

136 I previous now := now ; 

137 I now := date (hardwares today) + time (haa*dwares time) 

138 I UNTIL now = previous now OR is error PER ; 

139 I clear error ; 

140 I enable stop . 

141 1 

142 getdateandtimefromuser |get date and time from user : 

143 I line (2) ; 

144 j put (" Bitte geben Sie das heutige Datum ein :") ; 

145 I date text : = date ; 

146 I TEXT VAR exit char ; 

147 I editget (date text, cr, exit char) ; 

148 I now := date (date text) ; 

149 I line ; 

150 I put C und die aktuelle Uhrzeit :**) ; 

151 I date text := time of day ; 

152 I editget (date text, cr, exit char) ; 

153 I now INCR time (date text) ; 

154 I IF NOT last conversion ok 

155 I THEN errorstop ("Falsche Zeitangabe") 

156 I FI . 

157 I 

158 hardwares today | hardwares today : calendar (3) + + calendar (4) + + 
+ I calendar (5) . 

159 I 

160 hardwarestime [hardwares time : calendar (2) + **:" + calendar (1) . 

161 I 

162 definedateandtime [define date and time : 

163 I set clock (now) . 

164 I 
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165 
166 



167 calendar 

168 
169 
170 
171 
172 
173 
174 
175 

176 lowdigit 
177 

178 highdigit 

179 

180 

181 



182 shutup 

183 

184 

185 

186 

187 

188 

189 

190 

191 



192 savesystem 

193 

194 

195 

196 

197 

198 

199 

200 

201 



202 collectgarbageblocks 

203 

204 

205 

206 

207 



208 fixpoint 

209 

210 

211 

212 

213 



ENDPROC set date ; 



TEXT PROC calendar (INT CXDNST index) : 
INT VAR bed ; 

control (10, index, 0, bed) ; 
IF bed < 0 

THEN hardware clock ok := FALSE ; 

ELSE text (low digit + 10 • high digit) 
FI . 



low digit : bed AND 15 . 



high digit: (bed AND (15»256)) DIV 256 . 
ENDPROC calendar ; 



PRCX3 shutup : 
page ; 

cursor (32, 15) ; 

put ("bitte warten") ; 

cursor (35, 12) ; 

system operation (shutup code) 

ENDPROC shutup ; 



PROC save system : 

archive ("save") ; 

IF yes ("Leere Floppy eingelegt") 

THEN 

system operation (shutup and save code) ; 
FI. 

ENDPROC save system ; 



PROC collect garbage blocks : 

system operation (garbage collect code) 
ENDPROC collect garbage blocks ; 



PROC fixpoint : 

system operation (fixpoint code) 
ENDPROC fixpoint ; 
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214 systemoperation |PROC system operation (INT CONST code) : 

215 I 

216 I INT VAR size, used ; 

217 I storage (size, used) ; 

218 j IF used <= size 

219 I THEN disable stop ; 

220 I sys op (code) ; 

221 I ignore start message error 

222 I ELSE errorstop ("nicht genuegend System - Speicher vorhanden") 

223 I FI . 

224 I 

225 ignorestartmessageerro | ignore start message error : 

226 I pause (5) ; 

227 I clear error . 

228 I 

229 lENBPROC system operation ; 

230 I 

231 sysop I PROC sys op ( INT CONST code ) : 

232 I EXTERNAL 90 

233 lENDPROC sys op ; 

234 I 

235 setclock |PROC set clock (REAL CONST time) : 

236 I EXTERNAL 103 

237 lENDPROC set clock ; 

238 I 

239 lENDPACKET single user monitor ; 
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1 |ke ; (« maintenance ke ») 

2 I 

3 sysgenoff |PROC sysgen off (INT CONST mode, INT VAR a,b,c,ci,e,f ,g,h,i, j.k) 

4 I EXTERNAL 256 

5 lENDPROC sysgen off ; 

6 I 

7 I INT VAR X := 0 ; 

8 Isysgen off (3,x,x,x,x,x,x,x,x,x,x,x) ; 
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1 i 

2 I check on ; 

3 I command dialogue (TRUE) ; 

4 I set clock (date ("19.06.86*')) ; 

5 {disable stop ; 

6 [save system ; 

7 I REP UNTIL yes ("help*') PER ; 

8 [archive ("help") ; 

9 1 fetch ("help", archive) ; 

10 I REP UNTIL yes ("dev") PER ; 

11 I archive ("dev") ; 

12 I fetch all (archive) ; 

13 [release (archive) ; 

14 [save system ; 

15 I configurate ; 

16 I set up ; 

17 I monitor ; 
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1 |(» VERSION 11 06.03.86 

2 basicarchive | PACKET basic archive DEIINES 

3 I 

4 I archive blocks , 

5 I block number , 

6 I check read , 

7 I format archive , 
3 I read block , 

9 I read , 

1© I rewind , 

11 I search dataspace , 

12 I seek , 

13 I size , 

14 I skip dataspace , 

15 I write block , 

16 I write : 

17 I 

18 I INT VAR blocknr := © , 

19 I rerun := 0 ♦ 

20 I pa^e := -1 , 

21 I bit word := 1 , 

22 I unreadable sequence length :» 0 ; 

23 I INT CONST all ones :=-l ; 

24 I 

25 I 

26 [DATASPACE VAR label ds ; 

27 I 

28 [LET write normal = 0 , 

29 I archive version = 1 » 

30 I first page stored = 2 , 

31 I dr size = 3 » 

32 I first bit word « 4 , 

33 |(* write deleted data mark = 64 , ») 

34 I inconsistent = 90 , 

35 I read error = 92 , 

36 I label size = 131 ; 

37 I 

38 I BOUND STRUCT (ALIGN dummy for pagel, 

39 I (* Pago 2 begins: •) 

40 I ROW label size INT lab) VAR label; 

41 I 

42 I 

43 blocknumber | INT PROC block number : 

44 I block nr 

45 lENDPROC block number ; 

46 1 

47 seek I PROC seek (INT CONST block) : 

48 I block nr := block 

49 lENDPROC seek ; 

50 I 

51 rewind I PROC rewind : 

52 I forget (label ds); 

53 I label ds := nilspace; 

54 1 label := label ds; 

55 I block nr := 0; 

56 I rerun := session 
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57 I END PROC rewind; 

53 I 

59 skipdataspace i PRCX; skip dataspace : 

60 I check rerun; 

61 I get label; 

62 I IF is error 

63 I THEN 

64 1 ELIF Olivetti 

65 I THEN block nr INCH label. lab (dr size+1) 

66 I ELSE block nr INCR label. lab (dr size) 

67 I FI 

68 I END PROC skip dataspace; 

69 I 

70 read I PROC read (DATASPACE VAR ds): 

71 I read (ds, 30000, FALSE) 

72 lENDPROC read ; 

73 I 

74 read I PROC read (DATASPACE VAR ds, INT CONST max pages, BOOL CONST error 

-t- I accept) : 

75 I enable stop ; 

76 I check rerun; 

77 I get label; 

78 I init next page; 

79 I INT VAR i ; 

80 I FOR i FROM 1 UPTO max pages REP 

81 I next page; 

82 I IF no further page THEN LEAVE read FI; 

83 I check storage ; 

84 I check rerun ; 

85 j read block ; 

86 I block nr INCR 1; 

87 I PER . 

88 I 

89 roadblock jread block : 

90 I disable stop ; 

91 I get external block (ds, page, block nr) ; 

92 I ignore read error if no errors accepted ; 

93 I enable stop . 

94 I 

95 ignorereaderrorifnoerr j ignore read error if no errors accepted : 

96 I IF is error CAND error code = read error CAND NOT error accept 

97 I THEN clear error 

98 I FI . 

99 I 

100 checkstorage | check storage : 

101 I INT VAR size, used ; 

102 j storage (size, used) ; 

103 I IF used > size 

104 I THEN forget (ds) ; 

105 I ds := nilspace ; 

106 I errorstop ( "Speicherengpass") ; 

107 I LEAVE read 

108 1 FI . 
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109 



110 checkrerun [check rerun : 

111 I IF rerun <> session 

112 I THEN errorstop ("RERUN beim Archiv-Zugriff ) ; 

113 I LEAVE read 

114 I FI . 

115 I 

116 I END PROC read; 

117 I 

118 checkread |PROC check read : 

119 I 

120 I enable stop ; 

121 I get label ; 

122 I INT VAR pages, i; 

123 I IF Olivetti 

124 I THEN pages := label. lab (dr size+1) 

125 I ELSE pages := label. lab (dr size) 

126 I FI ; 

127 I FOR i FROM 1 UPTO pages REP 

128 I get external block (label ds, 2, block nr) ; 

129 I block nr INCR 1 

130 I PER . 

131 I 

132 lENDPROC check read ; 

133 I 

134 write |PROC write (DATASPACE CONST ds): 

135 I enable stop ; 

136 I check rerun; 

137 I INT VAR label block nr := block nr; 

138 I block nr INCR l;init label; 

139 I INT VAR page := -l,i; 

140 I FOR i FROM 1 UPTO ds pages (ds) REP 

141 I check rerun ; 

142 I page := next ds page (ds» page ) ; 

143 I put external block (ds» page, block nr) ; 

144 I reset archive bit; 

145 I label. lab(dr size) INCR 1; 

146 I block nr INCR 1 

147 I PER; 

148 I put label. 

149 I 

150 1 

151 initlabel | init label: 

152 I label. lab( archive version) := 0 ; 

153 I label, lab( first page stored) := 0 ; 

154 I label. lab(dr size) := 0; 

155 I INT VAR j; 

156 I FOR j FROM first bit word UPTO label size REP 

157 I label. lab (j) := all ones 

158 I PER. 

159 I 

160 putlabel | put label: 

161 I put external block (label ds, 2, label block nr). 

162 I 
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163 resetarchivebit | reset archive bit: 

164 I reset bit (label. lab (page DIV 16+first bit word)» pa^e MOD 16). 

165 I 

166 I END PROC write; 

167 I 

168 getlabel |PROC get label: 

169 I 

170 I enable stop ; 

171 I get external block (label ds, 2, block nr) ; 

172 I block nr INCH 1; 

173 1 check label. 

174 I 

175 checklabel | check label: 

176 1 IF may be z80 format label OR may be old Olivetti format label 

177 i THEN 

178 I ELSE errorstop (inconsistent, "Archiv inkonsistent") 

179 I FI. 

180 I 

181 maybez80format label |may be z80 format label : 

182 I z80 archive AND label. lab(dr size) > 0 . 

183 I 

184 maybeoldolivettiformat |may be old Olivetti format label : 

185 I Olivetti AND label. lab( first page stored) =0 AND label. lab(dr 
+ I size+1) > 0 . 

186 I 

187 I END PROC get label; 

188 I 

189 nextpage | PROC next page : 

190 I IF z80 archive 

191 I THEN 

192 I WHILE labelbits = all ones REP 

193 I . bitword INCR 1; 

194 I IF bitword >= label size THEN 

195 I no further page := true; LEAVE next page FI 

196 I PER; 

197 I INT VAR p := lowest reset (labelbits); 

198 I set bit (labelbits, p) ; 

199 I page := 16*(bitword-first bit word)+p 

200 I ELSE 

201 I WHILE oli bits = 0 REP 

202 I bitword INCR 1; 

203 I IF bitword >= labelsize-64 THEN 

204 I no further page := true; LEAVE next page FI 

205 I PER; 

206 I p := lowest set (oli bits); 

207 I reset bit (dibits, p) ; 

208 I page := 16»(bitword-firstbitword)+p; 

209 I FI . 

210 I 

211 labelbits | label bits : label. lab (bitword). 

212 dibits | oli bits : label. lab (bitword+1). 

213 I 

214 I END PROC next page; 
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215 



216 Olivetti | Olivetti : label. lab (archive version) = -1. 

217 I 

218 z80archive |z80 archive : label. lab (archive version) = 0. 

219 I 

220 initnextpage |init next page: 

221 I BOOL VAR no further page := false; 

222 I bitword := first bit word. 

223 I 

224 checkrerun | check rerun : 

225 I IF rerun <> session 

226 I THEN errorstop ("RERUN beim Archiv-Zugriff*) 

227 I n . 

228 I 

229 getexternalblock |PROC get external block (DATASPACE VAR ds, INT CONST page, 

230 I INT CONST block nr): 

231 I 

232 I INT VAR error ; 

233 I read block (ds, page, block nr, error) ; 

234 I SELECT error OF 

235 I CASE 0: read succeeded 

236 I CASE 1: error stop ("Lesen unmoeglich (Archiv)") 

237 I CASE 2: read failed 

238 I CASE 3: error stop ( "Archiv-Ueberlauf " ) 

239 I OTHERWISE error stop (**??? (Archiv)") 

240 I END SELECT . 

241 I 

242 readsucceeded jread succeeded : 

243 I unreadable sequence length :> 0 . 

244 1 

245 readfalled jread failed : 

246 I unreadable sequence length INCR 1 ; 

247 I IF unreadable sequence length >= 3© 

248 I THEN errorstop ("30 unlesbare Bloecke hintereinander") 

249 I ELSE error stop (read error, "Lesefehler (Archiv)**) 

250 I FI . 

251 I 

252 I END PROC get external block; 

253 I 

254 putexternalblock | PROC put external block ( DATASPACE CONST ds , INT CONST page , 

255 I INT CONST block nr): 

256 I INT VAR error; 

257 I write block (ds, page, write normal, block nr, error) ; 

258 I SELECT error OF 

259 I CASE 0: 

260 I CASE 1: error stop ("Schreiben unmoeglich (Archiv)") 

261 I CASE 2: error stop { "Schreibf ehler (Archiv)") 

262 I CASE 3: error stop ( "Archiv-Ueberlauf") 

263 I OTHERWISE error stop ("??? (Archiv)") 

264 I END SELECT . 

265 I 

266 I END PROC put external block; 
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267 I 

268 readblock |PROC read block (DATASPACE VAR ds, 

269 1 INT CONST ds page no, 

270 i INT CX)NST block no. 

271 I INT VAR return code) : 

272 I read block; 

273 I retry if read error. 

274 I 

275 readblock jread block: 

276 1 block in (ds, ds page no, 0, block no, return code). 

277 I 

278 retry if readerror [retry if read error: 

279 1 INT VAR retry; 

280 I FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP 

281 I reset to block 0 if fifth try; 

282 I read block 

283 I PER. 

284 I 

285 resettoblock0iffifthtr | reset to block 0 if fifth try: 

286 I IF retry = 5 

287 I THEN block in (ds, ds page no, 0, 0, return code) 

288 I FI. 

289 I 

29© I END PROG read block; 

291 1 

292 writeblock |PROC write block (DATASPACE CONST ds, 

293 I INT CONST ds page no, 

294 I INT CONST mode, 

295 I INT CONST block no, 

296 I INT VAR return code): 

297 I write block; 

298 I retry if write error. 

299 I 

300 writeblock | write block: 

301 I block out (ds, ds page no, mode • 256, block no, return code) . 

302 I 

303 retry if writeerror | retry if write error: 

304 I INT VAR retry; 

305 I FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP 

306 I reset to block 0 if fifth try; 

307 I write block 

308 I PER. 

309 1 

310 resettoblock0iffifthtr [reset to block 0 if fifth try: 

311 I IF retry = 5 

312 I THEN disable stop; 

313 I DATASPACE VAR dummy ds := nilspace; 

314 I block in (dummy ds, 2, 0, 0, return code); 

315 j forget (dummy ds); 

316 I enable stop 

317 I FI . 

318 I 
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319 I END PROC write block; 

320 I 

321 size I INT PROC size (INT CONST key) : 

322 I 

323 I INT VAR return code ; 

324 I control (5, key, 0, return code) ; 

325 1 return code . 

326 I 

327 lENDPROC size ; 

328 I 

329 archiveblocks | INT PROC archive blocks : 

330 I size (0) 

331 lENDPROC archive blocks ; 

332 I 

333 searchdataspace | PROC search dataspace ( INT VAR ds pages ) : 

334 I 

335 1 disable stop ; 

336 I ds pages := -1 ; 

337 I INT CONST last block := archive blocks ; 

338 I 

339 I WHILE block nr < last block REP 

340 j IF block is dataspace label 

341 I THEN ds pages : = pages counted ; 

342 I LEAVE search dataspace 

343 I FI ; 

344 I block nr INCR 1 

345 I UNTIL is error PER . 

346 I 

347 block isdataspace label [block is dataspace label : 

348 I look at label block ; 

349 I IF is error 

350 I THEN IF error code = read error OR error code = inconsistent 

351 I THEN clear error 

352 I FI ; 

353 I FALSE 

354 I ELSE count pages ; 

355 I pages counted = number of pages as label says 

356 I FI . 

357 I 

358 lookatlabelblock |look at label block : 

359 I INT CONST 

360 I old block nr := block nr ; 

361 I get label ; 

362 I block nr := old block nr. 

363 I 

364 countpages [count pages : 

365 I INT VAR 

366 I pages counted := 0 ; 

367 I init next page ; 

368 I next page ; 

369 I WHILE NOT no further page REP 

370 I pages counted INCR 1 ; 

371 1 next page 
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372 I PER . 

373 I 

374 numberofpagesaslabelsa [number of pa^es as label says : label. lab (dr size) . 

375 I 

376 lENDPROC search dataspace ; 

377 I 

378 forma tarchive JPROC format archive (INT CONST format code) : 

379 I 

380 I IF format is possible 

381 I THEN format 

382 I ELSE errorstop (*" format' ist hier nicht implementiert**) 

383 I FI • 

384 I 

385 formatispossible [format is possible : 

386 I INT VAR return code ; 

387 I control (1,0,0, return code) ; 

388 I bit (return code, 4) . 

389 I 

390 format j format : 

391 I control (7, format code, 0, return code) ; 

392 I IF return code = 1 

393 I THEN errorstop ( "Formatieren unmoeglich" ) 

394 I ELIF return code > 1 

395 I THEN errorstop ( "Schreibfehler (Archiv)") 

396 I FI . 

397 I 

398 lENDPROC format archive ; 

399 I 

400 I END PACKET basic archive; 
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1 archivesingle »»»•*#»•»•*« | PACKET archive single DETINES (« Autor: 
+ I J.Liedtke») 

2 I (* Stand: 
+ I 31.07.85 ♦) 

3 I archive , 

4 I release » 

5 I save , 

6 I fetch , 

7 I erase , 

8 I check , 

9 I exists , 

10 I ALL , 

11 I cleax , 

12 I list , 

13 I format : 

14 I 

15 I 

16 I 

17 I LET archive channel = 31 , 

18 I main channel = 1 , 

19 I 

20 I read error = 92 , 

21 I 

22 I max files = 200 , 

23 I 

24 I start of volume = 1000 » 

25 I end of volume = 1 , 

26 I file header = 3 , 

27 I 

28 I number of header blocks = 2 , 

29 I 

30 I quote = , 

31 I dummy name = , 

32 I dummy date = ** " , 

33 I 

34 I 

35 I HEADER = STRUCT (TEXT name, date. INT type, TEXT password) ; 

36 I 

37 I 

38 I 

39 I TEXT VAR archive name write stamp ; 

40 I 

41 I REAL VAR last access time := 0.0 ; 

42 i 

43 I BOOL VAR was already write access := FALSE ; 

44 I 

45 I 

46 IDATASPACE VAR header space := nilspace , ds := nilspace ; 

47 I BOUND HEADER VAR header ; 

48 I 

49 I TEXT VAR file name := ; 

50 I 

51 I LET invalid = 0 , 

52 I read only = 1 , 

53 1 valid = 2 ; 

54 1 

55 ILET accept read errors = TRUE , 

56 I ignore read errors = FALSE ; 

57 I 

58 I 

59 jiNT VAR directory state := invalid ; 

60 I 
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61 I THESAURUS VAR directory , all names ; 

62 I INT VAR dir index ; 

63 I 

64 I INT VAR archive size ; 

65 I 

66 I INT VAR end of volume block ; 

67 I ROW max files INT VAR header block ; 

68 I ROW max files TEXT VAR header date ; 

69 1 

70 I 

71 I 

72 archive |PROC archive (TEXT CONST name) : 

73 I 

74 I disable stop ; 

75 I directory state := invalid ; 

76 I archive name := name ; 

77 1 last access time := clock (1) . 

78 I 

79 lENDPROC archive ; 

80 I 

81 release |PROC release (TASK CONST t) : 

82 I 

83 I directory state := invalid 

84 I 

85 lENDPROC release ; 

86 I 

87 I 

88 accessarchive | PROC access archive : 

89 I 

90 I IF directory state = invalid 

91 I THEN open archive 

92 I ELIF last access more than two seconds ago 

93 I THEN check volume name ; 

94 I new open if somebody changed medium 

95 I FI . 

96 I 

97 lastaccessmorethantwos jlast access more than two seconds ago : 

98 I abs (clock (1) - last access time) > 2.0 . 

99 I 

100 newopenifsomebodychang |new open if somebody changed medium : 

101 I IF header. date <> write stamp 

102 I THEN directory state := invalid ; 

103 I access archive 

104 I FI . 

105 I 

106 openarchive jopen archive : 

107 I directory state := invalid ; 

108 j check volume name ; 

109 I write stamp := header. date ; 

110 I was already write access := FALSE ; 

111 I read directory ; 

112 I make directory valid if no read errors occurred . 

113 I 
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114 readdi rectory |reaxi directory : 

115 I directory := empty thesaurus ; 

116 I rewind ; 

117 I get next header ; 

118 I WHILE header. type = file header REP 

119 I IF directory CONTAINS header. name 

120 I THEN rename (directory, header. name, dummy name) 

121 I FI ; 

122 I insert (directory, heaxler . naune , dir index) ; 

123 I header block (dir index) := end of volume block ; 

124 1 header date (dir index) := header. date ; 

125 I get next header ; 

126 I PER . 

127 I 

128 makedirectoryvalidifno jmake directory valid if no read errors occurred : 

129 I IF directory state = invalid 

130 I THEN directory state := valid 

131 I FI . 

132 I 

133 |ENDPRCX3 access archive ; 

134 I 

135 accessfile |PROC access file (TEXT CONST name) : 

136 I 

137 I file name := name ; 

138 I dir index := link (directory, file name) . 

139 I 

140 lENDPROC access file ; 

141 I 

142 1 

143 checkvolumename jPROC check volume name : 

144 I 

145 I disable stop ; 

146 I archive size := archive blocks ; 

147 I read volume header ; 

148 I IF header. type <> start of volume 

149 I THEN simulate header (start of volume, "?????") 

150 I ELIF header. name <> archive name 

151 I THEN errorstop ("Archiv heisst + header, nsune + *'"*'*') 

152 I FI . 
±53 I 

154 readvolumeheader |read volume header : 

155 I rewind ; 

156 I read header ; 

157 I IF is error 

158 1 THEN clear error ; 

159 I simulate header (start of volume, "?????") 

160 i FI . 

161 I 

162 lENDPROC check volume name ; 

163 I 

164 getnextheader |PROC get next header : 

165 I 

166 I disable step ; 

167 I skip dataspace ; 
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168 I IF NOT is error 

169 I THEN read header 

170 I FI ; 

171 I IF is error 

172 1 THEN clear error ; 

173 I directory state := read only ; 

174 I search header 

175 I FI ; 

176 I end of volume block := block number - number of header blocks . 

177 I 

178 searchheader [search header : 

179 I INT VAR ds pages ; 

180 I search dataspace (ds pages) ; 

181 I IF ds pages < 0 

182 I THEN simulate header (end of volume, 

183 I ELIF NOT is header space 

184 I THEN simulate header (file header, "????? " + text (block 
+ I number)) 

185 I FI . 

186 I 

187 isheaderspace |is header space : 

188 I IF ds pages <> 1 

189 1 THEN FALSE 

190 I ELSE remember position ; 

191 I read header ; 

192 I IF read error occurred 

193 I THEN clear error; back to old position; FALSE 

194 j ELIF header format looks ok 

195 I THEN TRUE 

196 I ELSE back to old position ; FALSE 

197 I FI 

198 I FI . 

199 I 

200 readerroroccurred |read error occurred : 

201 I is error CAND error code = read error . 

202 I 

203 headerformatlooksok [header format looks ok : 

204 I header. type = file header OR header. type = end of volume . 

205 I 

206 rememberposition [remember position : 

207 I INT CONST old block nr := block number . 

208 [ 

209 backtooldposition (back to old position : 

210 I seek (old block nr) . 

211 I 

212 (ENDPROC get next header ; 

213 I 

214 I 

215 fetch jPROC fetch (TEXT CONST file name) : 

216 I 

217 I fetch (file name, archive) 

218 I 

219 [ENDPROC fetch ; 

220 I 
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221 fetch IPROC fetch (TEXT CONST file name, TASK CONST from) : 

222 I 

223 I enable stop; 

224 I IF NOT (from = archive) 

225 I THEN errorstop (*'Task gibt es nicht") 

226 I ELIF NOT exists (file name) COR overwrite permitted 

227 I THEN get archive file 

228 I FX . 

229 I 

230 getarchivefile jget archive file: 

231 I last param (file name) ; 

232 I disable stop ; 

233 I continue (archive channel) ; 

234 I fetch file (file name) ; 

235 I last access time := clock (1) ; 

236 j continue (main channel) ; 

237 I IF NOT is error 

238 I THEN forget (file name, quiet) ; 

239 I copy (ds, file name) 

240 I FI ; 

241 I forget (ds) . 

242 I 

243 overwritepermitted | overwrite permitted : 

244 I say ("eigene datei "****) ; 

245 I say (file name) ; 

246 I yes (*"*** ueberschreiben" ) . 

247 I 

248 lENDPROC fetch ; 

249 I 

250 fetchfile |PROC fetch file (TEXT CONST name) : 

251 I 

252 I enable stop ; 

253 I access archive ; 

254 I access file (name) ; 

255 I IF no read error remarked 

256 I THEN disable stop ; 

257 I fetch ds (accept read errors) ; 

258 I IF read error occurred 

259 I THEN remark read error 

260 I FI ; 

261 I enable stop 

262 j ELSE fetch ds (ignore read errors) 

263 I FI . 

264 I 

265 noreaderrorremarked jno read error remarked : 

266 I pos (name, ** mit Lesefehler**) = 0 . 

267 I 

268 readerroroccurred jread error occurred : 

269 I is error AND error code = read error . 

270 I 

271 remarkreaderror j remark read error : 

272 I dir index := link (directory, file name) ; 

273 I REP 

274 I file name CAT ** mit Lesefehler" ; 

275 I UNTIL NOT (directory CONTAINS file name) PER ; 
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276 I IF LENGTH file name < 100 

277 I THEN rename (directory, dir index, file name) 

278 I FI . 

279 I 

280 lENDPROC fetch file ; 

281 I 

282 fetchds |PROC fetch ds (BOOL CONST error accept) : 

283 I 

284 I enable stop ; 

285 I IF file name <> dummy name 

286 I THEN fetch from archive 

287 I ELSE error ("Name unzulaessig**) 

288 I FI . 

289 I 

290 fetchfromarchive (fetch from archive : 

291 I IF file in directory 

292 I THEN position to file ; 

293 I forget (ds) ; 

294 I ds := nilspace ; 

295 I read (ds, 30000, error accept) ; 

296 I ELIF directory state = read only 

297 I THEN error Cgibt es nicht (oder Lesefehler)**) 

298 I ELSE error ("gibt es nicht**) 

299 I FI . 

300 I 

301 positiontofile j position to file : 

302 I seek (header block (dir index) + number of header blocks) . 

303 I 

304 fileindirectory jfile in directory : dir index > 0 . 

305 I 

306 lENDPROC fetch ds ; 

307 I 

308 erase | PROC erase : 

309 I 

310 I erase (last param) 

311 I 

312 lENDPROC erase ; 

313 I 

314 erase |PROC erase (TEXT CONST file name) : 

315 I 

316 I erase (file name, archive) 

317 I 

318 lENDPROC erase ; 

319 I 

320 erase |PROC erase (TEXT CONST file name, TASK CONST dest) : 

321 I 

322 I IF dest = archive 

323 I THEN disable stop ; 

324 I continue (archive channel) ; 

325 I erase on archive (file name) ; 

326 I last access time := clock (1) ; 
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327 j continue (main channel) 

328 I ELSE errorstop ("Task gibt es nicht") 

329 I FI 

330 I 

331 lENDPRCXJ erase ; 

332 I 

333 eraseonarchive |PROC erase on archive (TEXT CONST file name) : 

334 I 

335 I enable stop ; 

336 I access archive ; 

337 I access file (file name) ; 

338 I continue (main channel) ; 

339 I IF NOT file in directory 

340 I THEN putline ("gibt es nicht") ; 

341 I LEAVE erase on archive 

342 I ELIF NOT yes (""""+file name+"*"' loeschen") 

343 I THEN LEAVE erase on archive 

344 I FI ; 

345 I continue (archive channel) ; 

346 I erase archive entry . 

347 I 

348 fileindirectory |file in directory : dir index > 0 . 

349 I 

350 lENDPROC erase on archive ; 

351 I 

352 erasearchiveentry |PROC erase archive entry : 

353 I 

354 I IF directory state = read only 

355 I THEN errorstop ("' save erase ' wegen Lesefehler verboten") 

356 I ELSE update write stajnp if first write access ; 

357 I erase archive 

358 I FI . 

359 I 

360 updatewritestampiffirs [update write stamp if first write access : 

361 I IF NOT war, already write access 

362 I THEN rewind ; 

363 I write stamp := text (clock (1), 13, 1) ; 

364 I write header (archive name, write stamp, start of volume) ; 

365 I was already write access := TRUE 

366 I FI . 

367 I 

368 erasearchive [erase archive : 

369 I IF file in directory 

370 I THEN IF is last file of archive 

371 I THEN cut off all erased files 

372 I ELSE rename to dummy 

373 I FI 

374 I FI . 

375 I 

376 fileindirectory [file in directory : dir index > 0 . 
377 
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yt6 : islastfileofarchive |is last file of archive : dir index = highest entry (directory) . 

379 I 

380 cutoffallerasedfiles jcut off all erased files : 

381 I directory state := invalid ; 

382 I REP 

383 I delete (directory, dir index) ; 

384 I dir index DECR 1 

385 I UNTIL dir index = 0 COR name (directory, dir index) <> dummy name 

I PER ; 

386 I behind last valid file ; 

387 I write end of volume ; 

388 I directory state := valid . 

389 I 

390 behindlastvalidfile | behind last valid file : 

391 I seek (header block (dir index +1)) ; 

392 I end of volume block := block number . 

393 I 

394 renametodummy [rename to dummy : 

395 I directory state := invalid ; 

396 I to file header ; 

397 I read header ; 

398 I to file header ; 

399 I header. name := dummy name ; 

400 I header. date := dummy date ; 

401 I write (header space) ; 

402 I rename (directory, file name, dummy name) ; 

403 I header date (dir index) := dummy date ; 

404 I directory state := valid . 

405 I 

406 tofileheader |to file header : 

407 I seek (header block (dir index)) . 

408 I 

409 lENDPROC erase archive entry ; 

410 I 

411 save |PROC save : 

412 I 

413 I save (last param) 

414 I 

415 lENDPROC save ; 

416 I 

417 save jPROC save (TEXT CONST file name) : 

418 I 

419 I save (file name, archive) 

420 I 

421 lENBPROC save ; 

422 I 

423 save |PROC save (TEXT CONST file name, TASK CONST to) : 

424 I 

425 I IF to = archive 

426 j THEN disable stop ; 

427 I continue (archive channel) ; 

428 I save to archive (file name) ; 
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429 I last access time := clock (1) ; 

430 I continue (main channel) 

431 1 ELSE errorstop ("Task gibt es nicht") 

432 I FI . 

433 I 

434 lENDPROC save ; 

435 I 

436 savetoarchive |PROC save to archive (TEXT CONST file name) : 

437 I 

438 I enable stop ; 

439 I access archive ; 

440 I access file (file name) ; 

441 I continue (main channel) ; 

442 I IF file in directory 

443 I THEN IF NOT yes ("*'""+file name+''*'** ueberschreiben") 

444 I THEN LEAVE save to archive 

445 I FI 

446 I FI ; 

447 I continue (archive channel) ; 

448 1 access archive ; 

449 I access file (file name) ; 

450 I erase archive entry ; 

451 I IF file name = dummy name 

452 I THEN error ("Name unzulaessig") 

453 I ELIF file too large OR highest entry (directory) >= max files 

454 I THEN error ("kann nicht geschrieben werden (Archiv voll)**) 

455 I ELSE write new file 

456 I FI . 

457 I 

458 fileindirectory [file in directory : dir index > 0 . 

459 I 

460 filetoo large jfile too large : 

461 I end of volume block + ds pages (ds) + 5 > archive size . 

462 I 

463 writenewfile 1 write new file : 

464 I seek (end of volume block) ; 

465 I disable stop ; 

466 I write file (file name, old (file name)) ; 

467 I IF is error 

468 I THEN seek (end of volume block) 

469 I ELSE insert (directory, file name, dir index) ; 

470 I remember begin of header block ; 

471 I remember date 

472 1 FI ; 

473 I write end of volume . 

474 I 

475 rememberbeginofheaderb | remember begin of header block : 

476 I header block (dir index) := end of volume block . 

477 I 

478 rememberdate | remember date : 

479 I header date (dir index) := date . 

480 I 

481 lENDPROC save to archive ; 

482 1 
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483 writefile |PROC write file (TEXT CONST file name, DATASPACE CONST ds) : 

484 I 

485 I enable stop ; 

486 I write header (file name, date, file header) ; 

487 I write (ds) 
486 I 

489 lENDPROC write file ; 

490 I 

491 writeendofvolume |PROC write end of volume : 

492 I 

493 j disable stop ; 

494 I end of volume block := block number ; 

495 j write header ("", end of volume) 

496 i 

497 lENDPROC write end of volume ; 

498 I 

499 writeheader |PROC write header (TEXT CONST name, date, INT CONST header type) : 

500 I 

501 I forget (header space) ; 

502 I header space := nilspace ; 

503 I header header space ; 

504 I 

505 I header. name := subtext (name, 1,100) ; 

506 I heeuier.date := date ; 

507 I header. type := header type ; 

508 I 

509 I write (header space) 

510 I 

511 lENLPROC write header ; 

512 I 

513 readheader | PROC read header : 

514 I 

515 I forget (header space) ; 

516 I header space := nilspace ; 

517 I read (header space, 1, accept read errors) ; 

518 I header header space . 

519 I 

520 lENDPROC read header ; 

521 I 

522 simulateheader |PROC simulate header (INT CONST type, TEXT CONST name) : 

523 I 

524 I forget (header space) ; 

525 I header space :« nilspace ; 

526 I header := header space ; 

527 I header. name := name ; 

528 I header. date := *•??.??.??" ; 

529 I header. type := type ; 

530 I header. password := 

531 I 

532 lENDPROC simulate header ; 

533 I 
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534 check |PROC check (TEXT CONST name, TASK CONST from) : 

535 1 

536 I IF from - archive 

537 I THEN check file 

538 I ELSE errorstop ("Task gibt es nicht") 

539 I FI . 
54® I 

541 checkfile (check file : 

542 I access archive ; 

543 I access file (name) ; 

544 I IF file in directory 

545 I THEN position to file ; 

546 I disable stop ; 

547 I check read ; 

548 I IF is error 

549 1 THEN clear error; error ( "f ehlerhaf t" ) 
55© I ELSE last access time := clock (1) ; 

551 I putline (*'"*"' + file name ■^ ohne Fehler gelesei. 

552 I FI 

553 I ELSE error ("gibt es nicht") 

554 I FI . 

555 I 

556 fileindirectory jfile in directory ; dir index > 0 . 

557 I 

558 positiontofile | position to file : 

559 I seek (header block (dir index) + number of header blocks) . 

560 I 

561 lENDPROC check ; 

562 1 

563 exists |BOOL PROC exists (TEXT CONST name, TASK CONST from) : 

564 I 

565 I IF from = archive 

566 I THEN access archive ; 

567 I access tile (name) ; 

568 I file in directory 

569 I ELSE FALSE 

570 I FI . 

571 I 

572 fileindirectory jfile in directory : dir index > 0 . 

573 I 

574 lENDPROC exists ; 

575 1 

576 list I PROC list (TASK CONST from) : 

577 I 

578 1 forget (ds) ; 

579 I d- :» nilspace ; 

580 I FILE VAR list file := sequential file (output, ds) ; 

581 I list (list file, from) ; 

582 I modify (list file) ; 

583 I show (list file) ; 

584 I forget (ds) . 

585 I 

586 lENDPROC list ; 

587 I 
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588 list IPROC list (FILE VAR list file, TASK CONST fron) : 

589 I 

590 j IF from = archive 

591 I THEN disable stop ; 

592 1 continue (archive channel) ; 

593 I list archive (list file) ; 

594 I last access time :« clock (1) ; 

595 I continue (main channel) 

596 I ELIF from = myself (* R. Nolting 
+ I 25.10.84 •) 

597 I THEN list( listfile) 

598 I ELSE errorstop ("Task gibt es nicht") 

599 1 FI . 

600 i 

601 lENDFRCX; list ; 

602 I 

603 listarchive |PROC list archive (FILE VAR list file) : 

604 I 

605 I enable stop ; 

606 I access archive ; 

607 I open list file ; 

608 I INT VAR file number := 0 ; 

609 I get (directory, file name, file number) ; 
61© I WHILE file number > 0 REP 

611 I generate list line ; 

612 I get (directory, file name, file number) 

613 I PER ; 

614 1 IF directory state » read only 

615 I THEN putline (list file, "Lesefehler: Evtl. fehlen Eintriige") 

616 I FI ; 

617 I write list head . 

618 I 

619 openlistfile |open list file : 

620 I output (list file) ; 

621 I putline (list file, "") . 

622 I 

623 generatelistline j generate list line : 

624 I write (list file, header date (file number)) ; 

625 I write (list file, text (file blocks DIV 2, 5)) ; 

626 I write (list file, " K **) ; 

627 I IF header. name * dummy name 

628 I THi3I write (list file, dumn^ name) 

629 I ELSE write (list file, quote) ; 

630 1 write (list file, file name ) ; 

631 I write (list file, quote) 

632 I FI ; 

633 I line (list file) . 

634 I 

635 fileblocks |file blocks : 

636 I IF file number < highest entry (directory) 

637 I THEN header block (file number+1) - header block (file number) 

638 I ELSE end of volume block - header block (file number) 

639 I n . 

640 I 
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641 writelisthead [write list head : 

642 1 headline (list file, archive name ♦ 

643 I + used + ** K belegt von " + text (archive size 
+ I 2) K)") . 

644 I 

645 used I used : text ((end of volume block + 3) DIV 2) . 

646 I 

647 lENDPROC list archive ; 

648 I 

649 ALL I THESAURUS OP ALL (TASK CONST from) : 

650 I 

651 I IF from = myself 

652 I THEN all 

6o3 I ELIF from = archive 

654 I THEN disable stop ; 

655 I continue (archive channel) ; 

656 I get all from archive ; 

657 I last access time := clock (1) ; 

658 I continue (main channel) ; 

659 I enable stop ; 
66G I all names 

661 I ELSE errorstop ("Task gibt es nicht**) ; 

662 I empty thesaurus 

663 I FI . 

664 I 

665 lENDOP ALL ; 

666 I 

667 getallfromarchive |PROC get all from archive : 

668 I 

669 I enable stop ; 

670 I access archive ; 

671 I all names := directory ; 

672 I WHILE all names CONTAINS dummy name REP 

673 I delete (all names, dummy name, dir index) 

674 I PER . 

675 I 

676 lENDPROC get all from archive ; 

677 I 

678 clear |PROC clear (TASK CONST dest) : 

679 I 

680 I IF dest = archive 

681 I THEN disable stop ; 

682 I continue (archive channel) ; 

683 I clear archive ; 

684 I continue (main channel) 

685 I ELSE errorstop ("Task gibt es nicht**) 

686 I FI . 

687 1 

688 lENDPROC clear ; 

689 I 

690 cleararchive |PROC clear archive : 

691 I 

692 I archive size := archive blocks ; 

S49/13 archive single S49/13 



Zeile »»*♦ ELAN EUMEL 1.8 10.11.86 archive single 



693 
694 
695 
696 
697 
698 

699 askforeraseall 

700 
701 
702 
703 
704 
705 
706 
707 
708 
709 
710 
711 
712 
713 
714 
715 
716 
717 
718 
719 
720 
721 



722 format 
723 
724 
725 
+ 

726 
727 
728 
729 
730 
731 
+ 

732 
733 
734 
735 
736 
737 
738 
739 



740 format 

741 

742 

743 

744 

745 



ask for erase all ; 
directory state := invalid ; 
rewind ; 

write header (archive name, text (clock(l) ,13,1) , start of volume) 
write end of volume . 



ask for erase all : 
rewind ; 
disable stop ; 
read header ; 
IF is error OR 

LENGTH header. name < 0 OR LENGTH header. name > 100 OR is error 
THEN header. name 
clear error 

FI ; 

enable stop ; 
continue (main channel) ; 
IF header. name <> **** 
THEN IF NOT yes ("archiv *'***'+header.name+*"'** loeschen") 
THEN LEAVE cleatr aj^hive 

FI 

ELSE IF NOT yes (**archiv initiallsieren") 
THEN LEAVE clear archive 

FI 

FI ; 

continue (archive channel) . 
ENDPROC clear archive ; 



PROG format (INT CONST format code. TASK CONST dest) : 

IF dest = archive 
THEN IF yes ( '•**7**Formatieren ueberschreibt alles! Richtige 
Diskette eingelegt**) 
THEN disable stop ; 

continue (archive channel) ; 
format archive (format code) ; 
directory state := invalid ; 
rewind ; 

write header ( archive name, text (clock (1), 13, 1) 

, start of volume) ; 
write end of volume ; 
continue (main channel) 

FI 

ELSE errorstop (**Task gibt es nicht**) 
FI . 

ENDPROC format ; 



IPROC format (TASK CONST dest) : 

format (0, dest) 
ENDPROC format ; 
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746 error |PROC error (TEXT CX)NST error msg) : 

747 I 

748 I error stop + file name + + error msg) 

749 I 

750 lENBPROC error ; 

751 I 

752 lENDPACKET archive single ; 
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1 |(« VERSION 4 22.04.86 •) 

2 konfigurleren *hhhhh»«»<mmmm» | PACKET konfiguriaren DEFINES (• Autor: D.Hainrlchs 

3 I 

4 I 

5 I 

6 I ansl cursor, 

7 I baudrate , 

8 I bits , 

9 I cursor logic , 

10 I elbit cursor » 

11 I enter incode , 

12 I enter outcode , 

13 I flow , 

14 I input buffer size , 

15 I link , 

16 I new configuration , 

17 I new type , 

18 I ysize : 

19 I 

20 I LET max dtype nr « 5, (» maximum number of active device tables ♦) 

21 I device table » 32000, 

22 I ack = 0 ; 

23 I 

24 1 

25 I INT VAR next outstring, 

26 I next instring; 

27 I 

28 1 BOUND STRUCT (ALIGN space, (♦ 
+ I umsetzcodetabelle ») 

29 I ROW 128 INT outcodes, 

30 I ROW 64 INT outstrings, 

31 I ROW 64 INT instrings) VAR x; 

32 I 

33 I 

34 I ROW max dtype nr DATASPACE VAR device code table; 

35 I 

36 I THESAURUS VAR dtypes ; 

37 I 

38 I 

39 newconf iguration | PROC new configuration : 

40 I 

41 I dtypes := empty thesaurus ; 

42 I INT VAR i ; 

43 I insert (dtypes, "psi", i) ; 

44 I insert (dtypes, "transparent", i) ; 

45 I FOR i FROM 1 UPTO max dtype nr REP 

46 I forget (device code table (i)) 

47 I PER . 

48 I 

49 lENDPROC new configuration ; 

50 I 

51 I 

52 blockout I PROC block out (DATASPACE CONST ds, INT CONST page, code): 

53 I INT VAR err; 

54 I block out ( ds, page, 0, code, err ) ; 

55 I announce error (err) 

56 I END PROC block out; 

57 I 
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58 announceerror |PROC announce error (INT CONST err): 

59 I SELECT err or 

60 I CASE 0: 

61 I CASE 1: errorstop ( "unbekanntes Terminalkonunando") 

62 I CASE 2: errorstop (*'Nununer der Terminal-Typ-Tabelle falsch") 

63 I CASE 3: errorstop ("falsche Terminalnuramer") 

64 I OTHERWISE errorstop ("blockout: unzulaessiger Kanal*') 

65 I ENDSELECT 

66 I END PROC announce error; 

67 I 

68 flow I PROC flow (INT CONST nr, INT CONST dtype): 

69 I control (6, dtype, nr) 

70 I END PROC flow; 

71 I 

72 ysize |PROC ysize (INT CONST channel ,new size, INT VAR old size) : 

73 I control (11, channel, new size, old size) 

74 lENDPROC ysize ; 

75 I 

76 inputbuffersize |PROC input buffer size (INT CONST nr,size): 

77 I INT VAR err; 

78 I control (2,nr,size,err) 

79 I END PROC input buffer size; 

80 I 

81 baudrate |PROC baudrate (INT CONST nr, rate) : 

82 I control (8, rate, nr) 

83 lENDPROC baudrate ; 

84 I 

85 bits I PROC bits (INT CONST channel, number, parity) : 

86 I bits (channel, number-1 + 8*parity) 

87 lENDPROC bits ; 

88 I 

89 bits I PROC bits (INT CONST channel, key) : 

90 I control (9, key, channel) 

91 lENDPROC bits ; 

92 I 

93 control |PROC control (INT CONST function, key, channel) : 

94 I 

95 I INT VAR err ; 

96 I IF key > -128 AND key < 127 

97 I THEN control (function, channel, key, err) 

98 I ELIF key = -128 

99 I THEN control (function, channel, -maxlnt-1, err) 

100 I FI 

101 I 

102 lENDPROC control ; 

103 I 

104 I 
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105 newtype |PROC new type (TEXT CONST dtype): 

106 I X : = new ( dtype ) ; 

107 j type (old (dtype), device table); 

108 I next outstring := 4; 

109 I next instring := 0; 

110 I INT VAR i; 

111 I (• Defaults, damit trmpret den cursor mitfuehrt: «) 

112 I FOR i FROM 1 UPTO 6 REP 

113 I enter outcode (1,1) 

114 I PER; 

115 I enter outcode (8,8); 

116 I enter outcode (10,10); 

117 I enter outcode (13,13); 

118 I enter outcode (14,126); 

119 I enter outcode (15,126); 

120 I END PROC new type; 

121 I 

122 activatedtype |INT PROC activate dtype (TEXT CONST dtype): 

123 I 

124 I INT VAR i := link (dtypes, dtype); 

125 I IF (exists (dtype) CAND type (old (dtype)) = device table) 

126 I THEN IP i <= 0 

127 I THEN insert (dtypes, dtype, i); 

128 I FI ; 

129 j forget(device code table (i-2)); 

130 I device code table (i-2) :» old (dtype) 

131 I FI; 

132 I IF i > max dtype nr +2 (•5 neue Typen erlaubt «) 

133 I THEN delete ( dtypes, i); 

134 I error stop ("Anzahl Terminaltypen > *'+text (i));0 

135 I ELIF i <= 0 

136 I THEN error stop ( **Unbekannter Terminaltyp" + dtype); 0 

137 I ELSE i 
136 I FI. 

139 I 

140 I END PROC activate dtype; 

141 I 

142 link |PROC link (INT CONST nr, TEXT CONST dtype): 

143 I 

144 I INT VAR 1st nr := activate dtype (dtype) -3; 

145 I IF 1st nr < 0 

146 I THEN 1st nr INCR 256 (• fuer std terniinal und std device •) 

147 j ELSE blockout (device code table(lst nr+1), 2, 1st nr); 

148 I FI; 

149 1 INT VAR err := 0; 

150 I control (l,nr,lst nr,err) ; 

151 I announce error(err) 

152 I 

153 I END PROC link; 

154 j 

155 I 

156 enteroutcode |PROC enter outcode (INT CONST euinel code, ziel code): 

157 I 

158 I IF ziel code < 128 

159 j THEN simple entry (eumel code, ziel code) 

160 I ELSE enter outcode (eunel code, 9, code (ziel code)) 

52/3 konfigurieren 52/3 



Zeile •••• ELAN EUMEL 



1.8 10.11.86 konfigurioren 



161 I FI . 

162 I 

163 lENDPROC enter outcode ; 

164 I 

165 simpleentry |PROC simple entry (INT CONST eumel code, ziel code) : 

166 I 

167 I INT CONST position := eumel code DIV 2 +1, 

168 I teil := eumel code - 2»position + 2; 

169 I TEXT VAR h 

170 I replace (h,l,out word); 

171 I replace (h,l+teil,code (ziel code)); 

172 I out word (h ISUB 1). 

173 I 

174 outword | out word: x.outcodes (position). 

175 I 

176 I END PROC simple entry ; 

177 I 

178 enteroutcode |PRCX3 enter outcode (INT CONST eumel code, wartezeit, 

179 I TEXT CONST sequenz): 

180 I 

181 I INT VAR i; 

182 I simple entry (eumel code, next outstring + 128); 

183 I enter part (x.outstrings, next outstring, wartezeit); 

184 I FOR i FROM 1 UPTO length (sequenz) REP 

185 I enter part (x.outstrings, next outstring + i, code 
+ I (sequenzSUBi) ) 

186 I PER; 

187 I next outstring INCR length (sequenz) +2; 

188 I abschluss. 

189 I 

190 abschluss j abschluss: 

191 I enter part (x.outstrings, next outstring-1, 0) 

192 I END PROC enter outcode; 

193 I 

194 enteroutcode |PROC enter outcode (INT CONST eumelcode, TEXT CONST wert): 

195 I enter outcode ( eumelcode, code ( wert ) ) 

196 lEND PROC enter outcode; 

197 I 

198 enterpart |PROC enter part (ROW 64 INT VAR a, INT CONST index, wert): 

199 1 INT CONST position := index DIV 2 +1, 

200 I teil := index - 2»positlon + 2; 

201 I IF position > 64 THEN errorstop ("Ueberlauf der 
+ I Terminaltyptabelle") FI; 

202 I TEXT VAR h :=" 

203 I replace (h,l,out word); 

204 I replace (h,l+teil,code (wert)); 

205 I out word := (h ISUB 1). 

206 I 

207 outword | out word: a (position). 

208 I END PROC enter part; 

209 I 
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211 enterincode |PROC enter incode (INT CONST elan code, TEXT CONST sequenz): 

212 I IF elan code > 254 OR elan code < 0 THEN errorstop ("kein 
+ I Eingabecode") 

213 I ELSE 

214 I INT VAR i; 

215 I enter part (x. instrings, next instring, elan code); 

216 I FOR i FROM 1 UPTO length (sequenz) REP 

217 I enter part (x. instrings, next instring + i, code 

I ( sequenzSUBi ) ) 

218 I PER; 

219 I next instring INCR length (sequenz) +2; 

220 I 

221 I FI 

222 I 

223 I END PROC enter incode; 

224 I 

225 cursor logic |PROC cursor logic (INT CONST dist, TEXT CONST pre, mid, post): 

226 I 

227 I cursor logic (dist, 255, pre, mid, post) 

228 1 

229 I END PROC cursor logic; 

230 I 

231 ansicursor |PROC ansi cursor (TEXT CONST pre, mid, post): 

232 I 

233 I cursor logic (0, 1, pre, mid, post) 

234 I 

235 I END PROC ansi cursor; 

236 I 

237 cursorlogic |PROC cursor logic (INT CONST dist, modus, TEXT CONST pre, mid, post) 

238 I 

239 I enter part (x.outstrings,2,dist) ; 

240 I enter part (x.outstrings,3,dist) ; 

241 I enter part ( x. outs trings,0, modus ) ; 

242 I enter part ( x.outstrings,!, modus ) ; 

243 I enter outcode (6,0,pre+**'*0'*y'*+mid+"'*0'*x''+post+*"*0****) 

244 I 

245 I END PROC cursor logic; 

246 I 

247 elbitcursor |PROC elbit cursor: 

248 I cursor logic ( 0, •'*'27*'*', "*',''*•) ; 

249 I enter part (x.outstrings,0,2) ; 

250 I enter part (x.outstrings,l,255) ; 

251 I END PROC elbit cursor; 

252 I 

253 lENDPACKET konfigurieren; 
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1 |(» VERSION 11 10.06.86 •) 

2 configurators ingle | PACKET configurator single DEFINES 

3 I 

4 I configurate , 

5 I exec configuration , 

6 I setup : 

7 I 

8 I LET baudrates = '"•l'*50"2''75*'3*'110''4"134.5''5**150**6'*300**7"60e 

9 I "8**1200'*9''18©0''10"2400''11'*3600*'12"4800"13"7200 

10 |"14*'9600"15"19200'*16*'38400"17*'", 

11 I parities = ""0"no"l*'odd"2**even"3"" , 

12 I bits per char = ""0''1*'1''2"2*'3"3''4"4''5"5*'6"6"7*'7''8*'8*"' , 

13 I stopbits = "'•0"l*'l*'l.5"2*'2**3**" , 

14 I flow modes = "**0"ohne Protokoll**l"X0N/X0FF"2"RTS/CTS 

15 I "3""4*'**5*'X0N/X0IT - ausgabeseitig"6**RTS/CTS - ausgabeseitig"7""8" 

16 |"9"X0N/X0IT - eingabeseitig-lO^RTS/CTS - eingabeseitig-ll**" . 

17 I 

18 I ok = "j" , 

19 I esc = ""27*"' , 

20 I cr = ""13"" . 

21 I right = "**2''" , 

22 I 

23 I psi = "psi" , 

24 I transparent = "transparent" , 

25 I 

26 I std rate = 14 , 

27 1 std bits « 22 , 

28 I std flow = 0 , 

29 I std inbuffer size = 16 , 

30 I 

31 I device table = 32000 , 

32 I 

33 I max edit terminal » 15 , 

34 I configuration channel = 32 , 

35 I 

36 I CONF = STRUCT (TEXT dev type, 

37 I INT baud, bits par stop, flow control, inbuffer 
+ I size) ; 

38 I 

39 1 

40 I BOUND ROW max edit terminal CONF VAR conf ; 

41 I 

42 I INT VAR channel no ; 

43 I 

44 I TEXT VAR prelude , last feature , answer ; 

45 I 

46 I 

47 1 

48 shardpermits |BOOL PROC shard permits (INT CONST code, key) : 

49 I 

50 I INT VAR reply ; 

51 I IF key > -128 

52 I THEN control (code, channel no, key, reply) 

53 I ELSE control (code, channel no, -maxint-1, reply) 

54 I FI ; 

55 I reply = 0 . 

56 I 

57 lENDPROC shard permits ; 

58 I 
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59 askuser |PROC ask user (TEXT CONST feature » question) : 

60 I 

61 I last feature := feature ; 

62 I put question ; 

63 I skip pretyped chars ; 

64 I get valid answer . 

65 I 

66 putquestion |put question : 

67 I clear line ; 

68 I out (prelude) ; 

69 I out (feature) ; 

70 I out (question) ; 

71 I out (" (j/n) ") . 

72 I 

73 clearline j clear line : 

74 I out (cr) ; 

75 I 79 TIMESOUT " ; 

76 I out (cr) . 

77 I 

78 skippretypedchars I skip pretyped chars : 

79 1 REP UNTIL incharety = **** PER . 

80 I 

81 getvalidanswer jget valid answer : 

82 I REP 

83 I inchcu: (answer) 

84 I UNTIL pos ("jJyYnN"27"", answer) > 0 PER ; 

85 I IF answer > ""si**" 

86 1 THEN out (answer) 

87 I FI ; 

88 I out (cr) ; 

89 I normalize answer . 

90 I 

91 nomalizeanswer | normalize answer : 

92 I IF pos CjJyY'*, answer) > 0 

93 1 THEN answer := ok 

94 I FI . 

95 I 

96 lENDPRCX; ask user ; 

97 I 

98 yes |BOOL PROC yes (TEXT (X)NST question) : 

99 I 

100 I ask user C", question) ; 

101 I answer = ok 

102 I 

103 lENDPROC yes ; 

104 I 

105 chosekey |PROC chose key (INT VAR old key» INT CX)NST max key, TEXT COUST key 

+ I string, 

106 I key entity, BOOL PROC (INT CONST) shard permits): 

107 I 

108 I IF shard permits at least one standard key 

109 i THEN try all keys 

110 I FI . 
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111 I 

112 shardpennitsatleastone | shard permits at least one standard key : 

113 I INT VAR key ; 

114 I FOR key FROM 0 UPTO max key REP 

115 I IF shard permits (key) 

116 I THEN LEAVE shard permits at least one standard key WITH TRUE 

117 I FI 

118 I PER ; 

119 I FALSE . 

120 I 

121 tryallkeys jtry all keys : 

122 I key ;= old key ; 

123 I REP 

124 I examine this key ; 

125 I next key 

126 I PER . 

127 I 

128 examine thiskey j examine this key : 

129 1 IF shard permits (key) CAND key value <> 

130 I THEN ask user (key value, key entity) ; 
131' I IF answer = ok 

132 I THEN chose this key 

133 1 ELIF answer = esc 

134 I THEN key := -129 

135 I FI 

136 I PI . 

137 I 

138 keyvalue |key value : 

139 I IF key >= 0 

140 1 THEN subtext (key string, key pos + 1, next key pos - 1) 

141 I ELSE text (key) 

142 I FI . 

143 I 

144 keypos |key pos : pos (key string, code (key)) . 

145 nextkeypos |next key pos : pos (key string, code (key+D) . 

146 1 

147 chosethiskey j chose this key : 

148 I remember calibration ; 

149 I old key := key ; 

150 I LEAVE chose key . 

151 I 

152 nextkey jnext key : 

153 I IF key < max key 

154 I THEN key INCR 1 

155 I ELSE key := 0 

156 I FI . 

157 I 

158 remembercalibration | remember calibration : 

159 I prelude CAT last feature ; 

160 I prelude CAT **, " . 

161 i 

162 lENDPROC chose key ; 

163 I 
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164 rateok I BOOL PROC rate ok (INT CONST key) : 

165 I 

166 I shard permits (8, key) 

167 I 

168 lENDPROC rate ok ; 

169 I 

170 bitsok I BOOL PROC bits ok (INT CONST key) : 

171 I 

172 I IF key < 0 

173 I THEN shard permits (9, key) 

174 I ELSE some standard combination ok 

175 I n . 

176 I 

177 somes tandardcombinatio |some standard combination ok : 

178 I INT VAR combined := key ; 

179 I REP 

180 I IF shard permits (9, combined) 

181 I THEN LEAVE bits ok WITH TRUE 

182 I FI ; 

183 I combined INCR 8 

184 I UNTIL combined > 127 PER ; 

185 I FALSE 

186 I 

187 lENDPROC bits ok ; 

188 1 

189 parityok |BOOL PROC parity ok (INT CONST key) : 

190 1 

191 I INT VAR combined := 8 » key + data bits ; 

192 I key >= 0 AND (shard permits (9, combined) OR 

193 I shard permits (9, combined + 32) OR 

194 I shard permits (9, combined +64) ) 

195 I 

196 lENDPROC parity ok ; 

197 I 

198 stopbitsok jBOOL PROC stopbits ok (INT CONST key) : 

199 I 

200 j key >= 0 AND shard permits (9, 32 « key + 8 » parity + data bits) 

201 I 

202 lENDPROC stopbits ok ; 

203 I 

204 flowmodeok |BOOL PROC flow mode ok (INT CONST key) : 

205 I 

206 I shard permits (6, key) 

207 I 

208 lENDPROC flow mode ok ; 

209 I 

210 I 

211 I 

212 I INT VAR operators channel , 

213 I data bits , 

214 I parity , 

215 I stop ; 

216 I 
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217 
218 
219 



220 configurate 

221 
222 
223 
224 
225 
226 
227 
228 
229 
230 
231 
232 
233 
234 
235 
236 
237 

238 accessconfigurationtab 

239 

240 

241 

242 

243 

244 

245 inltializeconfiguratio 
246 
247 
248 
+ 

249 
250 
251 

252 showalldevicetypes 

253 

254 

255 

256 

257 

258 

259 

260 

261 

262 

263 

264 showprelude 

265 

266 

267 

268 



TEXT VAR table name, dummy ; 



PRCX; configurate : 

new configuration ; 

access configuration table ; 

show all device types ; 

channel no := 1 ; 

REP 

IF channel hardware exists 
THEN try this channel ; 
setup this channel 

FI ; 

channel no INCR 1 
UNTIL channel no > 15 PER ; 
prelude := ; 

IF yes ("Koennen unbenutzte Geraetetypen geloescht werden") 
THEN forget unused device tables 

I FI . 



access configuration table : 
IF exists ("configuration") 
THEN conf := old ("configuration") 
ELSE conf := new ("configuration") ; 
initialize configuration 

FI . 



initialize configuration : 
FOR channel no FROM 1 UPTO max edit terminal REP 
conf (channel no) := 

CONF: (transparent, std rate, std bits, std flow, std inbuffer 
size) 

PER ; 

conf (l).dev type := psi . 



show all device types : 
show prelude ; 
begin list ; 

get list entry (table name, dummy) ; 
WHILE table name <> "" REP 

IF dataspace is device table 
THEN show table name 

FI ; 

get list entry (table name, dummy) 
PER ; 

line (2) . 



show prelude : 
line (30) ; 

outtext (psi, 1, 20) ; 
outtext (transparent, 1, 2©) . 
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269 dataspaceisdevicetable 

270 

271 

272 showtablename 

273 
274 

275 trythlschannel 

276 

277 

278 

279 

280 

281 

282 

283 

284 channelh&rdwareexists 

285 

286 

287 

288 

289 

290 

291 

292 

293 

294 

295 

296 

297 

298 

299 

300 

301 getchanneltypefromshar 

302 

303 

304 Inoutmask 
305 

306 forgetunuseddevicetabl 

307 

308 

309 

310 

311 

312 

313 

314 

315 

316 forgetifunused 

317 
318 
319 
320 
321 
322 
323 



dataspace is device table : 

type (old (table name)) = device table . 



show table name : 

outtext (table name, 1» 20) . 



try this channel : 
prelude := "Kanal " ; 
ask user (*"*, text (channel no)) ; 
IF answer = ok 
THEN prelude CAT text (channel no) + **: ** ; 

get configuration from user (conf (channel no)) ; 
line 

FI . 



channel hardware exists : 
operators channel := channel ; 
INT VAR channel type ; 
disable stop ; 
continue (channel no) ; 
IF is error 
THEN IF error message = "kein Kanal" 
THEN channel type := 0 
ELSE channel type := inout mask 

FI 

ELSE get channel type from shard 
FI ; 

clear error ; 
disable stop ; 

continue operators channel ; 
(channel type ANT inout mask) <> 0 . 



get channel type from shajyl : 

control (1, 0, 0, channel type) . 



inout mask : 3 . 



forget unused device tables ; 
begin list ; 

get list entry (table name, dummy) ; 
WHILE table name <> REP 

IF type (old (table name)) = device table 
THEN forget if unused 

FI ; 

get list entry (table name, dummy) 
PER . 



forget if unused : 
FOR channel no FROM 1 UPTO max edit terminal REP 
IF conf (channel no).dev type = table name 
THEN LEAVE forget if unused 

FI 
PER ; 

forget (table name, quiet) . 
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324 setupthischannel [setup this channel : 

325 1 operators channel := channel ; 

326 I disable stop ; 

327 I continue (configuration channel) ; 

328 I set up channel (channel no, conf (channel no)) ; 

329 I continue operators channel . 

330 I 

331 continueoperatorschann [continue operators channel : 

332 I continue (operators channel) ; 

333 I IF is error 

334 I THEN clear error ; 

335 1 LEAVE configurate 

336 I FX ; 

337 I enable stop . 

338 I 

339 lENLPROC configurate ; 

340 I 

341 getconfigurationfromus ...|PROC get configuration from user (CONF VAR conf) : 

342 I 

343 I get device type ; 

344 I get baud rate ; 

345 I get bits and parity and stopbits ; 

346 I get protocol ; 

347 I get buffer size . 

348 I 

349 I 

350 getdevicetype |get device type ; 

351 I begin list ; 

352 I table name := conf.dev type ; 

353 I IF NCDT is valid device type 

354 I THEN next device type 

355 1 FI ; 

356 I REP 

357 I IF NOT (table name = transparent AND channel no = 1) 

358 I THEN ask user C**, table name) ; 

359 I IF answer = ok COR was esc followed by type table name 

360 I THEN IF is valid device type 

361 I THEN remember device type ; 

362 I LEAVE get device type 

363 I ELSE out C**?" unbekannter Typ"); pause (20) 

364 I FI 

365 I FI 

366 I FI ; 

367 I next device type 

368 I PER . 

369 I 

370 wasescfollowedbytypeta jwas esc followed by type table name : 

371 j IF answer = esc 

372 I THEN 9 TIMESOUT right ; 

373 I put CTyp:") ; 

374 I editget (table name) ; 

375 I TRUE 

376 I ELSE FALSE 

377 I FI . 

378 I 
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379 isvaliddevicetype |is valid device type : 

380 I table name = psi OR table name = transparent OR 

381 I (exists (table name) CAND type (old (table name)) = device table) 

382 I 

383 rememberdevicetype [remember device type : 

384 I prelude CAT table name ; 

385 I conf.dev type := table name ; 

386 I prelude CAT " . 

387 1 

388 nextde vice type [next device type : 

389 I IF table name = psi 

390 I THEN table name := transparent 

391 I ELSE IF table neune = transpcu:ent 

392 I THEN begin list 

393 I FI ; 

394 I search next device type space 

395 1 FI . 

396 I 

397 searchnextdevicetypesp [search next device type space : 

398 I REP 

399 I get list entry (table name, dummy) 

400 I UNTIL table name = COR type (old (table name)) = device table 
+ 1 PER; 

401 I IF table name = 

402 I THEN table name := psi 

403 I FI . 

404 I 

405 getbaudrate jget baudrate : 

406 I chose key (conf.baud, 16, baudrates, ** Baud", PROC rate ok) . 

407 I 

408 getbitsandparityandsto |get bits and parity and stopbits : 

409 I data bits := conf.bits par stop MOD 8 ; 

410 I parity := (conf.bits par stop DIV 8) MOD 4 ; 

411 I stop := (conf.bits par stop DIV 32) MOD 4 ; 

412 I chose key (data bits, 7, bits per char, " Bits", PROC bits ok) ; 

413 I IF data bits >= 0 

414 I THEN chose key (parity, 2, parities, " parity**, PROC parity ok) 

415 I chose key (stop, 2, stopbits, ** Stopbits**, PROC stopbits 
+ I ok); 

416 I conf.bits par stop := data bits 8 • parity + 32 • stop 

417 I ELSE conf.bits par stop := data bits 

418 I FI . 

419 I 

420 getprotocol jget protocol : 

421 I chose key (conf.flow control, 10, flow modes, 

422 I •***, PROC flow mode ok) . 

423 I 

424 getbuffersize jget buffer size : 

425 I IF dev type is transparent 

426 I THEN chose buffer size 

427 I ELSE conf .inbuffer size := std inbuffer size 

428 I FI . 

429 I 
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430 devtypeistransparent |dev type is transparent : 

431 I conf.dev type » "transparent** . 

432 I 

433 chosebuffersize | chose buffer size : 

434 I REP 

435 I IF conf.inbuffer size = 16 CAND yes C'nonnaler Puffer**) 

436 I THEN LEAVE chose buffer size 

437 I ri ; 

438 I conf.inbuffer size := 512 ; 

439 I IF yes ("grosser Puffer**) 

440 j THEN LEAVE chose buffer size 

441 I FI ; 

442 1 conf.inbuffer size := 16 

443 I PER . 

444 I 

445 lENDPROC get configuration from user ; 

446 i 

447 execconfiguration |PROC exec configuration : 

448 I 

449 I setup 

450 I 

451 lENDPROC exec configuration ; 

452 I 

453 setup IPROC setup : 

454 I 

455 I conf := old ( *'conf iguration** ) ; 

456 I continue (configuration channel) ; 

457 I FOR channel no FROM 1 UPTO max edit terminal REP 

458 I set up channel (channel no, conf (channel no)) 

459 I PER ; 

460 I continue (operators channel) . 

461 I 

462 lENDPROC set up ; 

463 I 

464 setupchannel |PROC set up channel (INT CONST channel no, CONF CONST conf) : 

465 i 

466 I link (channel no, conf.dev type) ; 

467 I baudrate (channel no, conf. baud) ; 

468 I bits (channel no, conf. bits par stop) ; 

469 I flow (channel no, conf. flow control) ; 

470 I input buffer size (channel no, conf.inbuffer size) . 

471 I 

472 lENDPROC setup channel ; 

473 I 

474 lENDPACKET configurator single ; 

475 I 
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